perm filename PUPFTP.FAI[S,NET]11 blob
sn#829950 filedate 1986-12-02 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00071 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00010 00002 TITLE PUPFTP - FTP for the Ethernet
C00015 00003 Remarks and History
C00029 00004 RET RET2 TAC TAC2 P INCHN OUTCHN PUPCHN MFDCHN UFDCHN PROCHN RCUNDF RCNOUS RCILGC RCMFPL RCILSF RCILDR RCILNB RCILVR RCILTY RCILUS RCILPS RCILAC RCILDV RCILMB RCFNF RCPROF RCFDER RCFULL RCNORE RCNOST RCTFSF RCFBSY SNNEXT SNONS SNOFFS SNSIZE
C00034 00005 ------------------------------------------------------------------------------
C00038 00006 -------------------------------------------------------------------------------
C00041 00007 DRYROT WARNMS ERROR1 ERRLP ERRTAB ERREND ERRCHR ERRSIX ERROCT ERRTXT ERRCRLF ERTYPS PUPERR DRYROT WARNMS WARNM2 ERROR1 ERRLP ERRBUG ERRJM1 ERRJM2 ERRJM3 ERRXCT ERRTAB ERREND ERRCHR ERRSIX ERROCT ERRDEC ERRTXT ERRCRLF ERTYPS PUPERR STOP
C00049 00008 START RESCN1 RESCN2 RESCN3 START0 START1 START2 PCONFIG USERBG HNMLP GETWIZ GRTLP ENDGRT UVERST TXSPRE GIVEUP INITDN
C00060 00009 USERLP USERL1 USERL2 GOTCMD UFLUSH
C00064 00010 TERREAD TERRE2 NOCRLF UGETST URELST URELS2 CMDTRM UUNIMP USQUIT
C00068 00011 USHELP HELP1 HELP1A HELP1B HELP1D
C00072 00012 USTYPE USTXT2 USTEXT USTNX USBYTE USEOLC
C00079 00013 USUSER USUSR5 USACCT USALIA
C00083 00014 USXIND CHGCMD SETCMD
C00087 00015 SRVRBG SRVRB2 SRVRB3 SRVRLP SRVDSP SRRENA NOTSUP
C00091 00016 SRYUSR SRVERS SVERST SRCOMM
C00095 00017 BADMRK CNTXER NOEOC EOCSNK CLOSED
C00099 00018 SUBR SRRETR Server Retrieve (also SRDELE)
C00118 00019 SUBR SRNSTO Server Store, Both styles (include SRSTOR)
C00129 00020 SUBR SRDIR Server Directory
C00139 00021 SUBR SRSMAI Server Send Mail
C00156 00022 SUBR SRVLMS,PREAMB Log/flush message in server mode
C00158 00023 SUBR USRETR RETR command (also USDELE, EOLHAK)
C00177 00024 SUBR USSTOR User Store
C00196 00025 SUBR USLIST LIST command (also USNLST for NLST)
C00201 00026 SUBR USMLFL Send Mail file
C00210 00027 SUBR USRLMS,PREAMB Log/flush message in user mode
C00212 00028 SUBR CONFRM Ask user for confirmation
C00215 00029 SUBR DORCV,CRONLY,BINARY Tranfer Remote -> Local
C00232 00030 SUBR DOSND,CRONLY,BINARY Transfer Local -> Remote
C00247 00031 SUBR SNDLPL,IOBLK,OTHER Send property list from LOOKUP (also OPNPRN,CLSPRN,PUPQCK)
C00255 00032 SUBR SNDUPL,OPCODE,OTHER Send property list from user
C00257 00033 SUBR SNDUNM Send user name and other information
C00260 00034 SUBR RDPLST,OPCODE Read a property list
C00263 00035 SUBR RDPROP,OPCODE Read a property list element
C00270 00036 SUBR RDNAME,OPCODE Read a name
C00273 00037 SUBR RDSTRB,BRKTAB,OPCODE Read a string according to break table.
C00276 00038 SUBR RDEHST,OPCODE Read Ethernet host name
C00286 00039 SUBR GTHNAM,NUM Get Ethernet host name from number
C00289 00040 SUBR RLPLST,PLST Release space from Property List
C00292 00041 SUBR PLGET,PLST,PNAMCD Search property list
C00294 00042 SUBR PLSTNM,PLST,IOBLK Derive file name from property list
C00308 00043 SUBR PLSTSL,PLST Construct a search list from property list
C00318 00044 SUBR STRSL,SRCSTR,UFDSW Construct search sublist from string.
C00334 00045 SUBR MAPSL,SRCLST,READOP,FN Apply FN on files matching search list
C00338 00046 SUBR RLSL,SRCLST Release space from Search List
C00340 00047 SUBR CHKPRO,PLIST,IOSPEC,ACCTYP Check file protection
C00350 00048 SUBR CHKDEV,DEVNAM Check file protection
C00354 00049 SUBR FNDUSR,KEYSTR Find user name (check legality)
C00362 00050 SUBR COPSTR,STRPTR Copy a string
C00366 00051 SUBR UPSTR,STRPTR Convert string to upper case
C00368 00052 SUBR HASHER,VALUE Hash a number into another number
C00370 00053 SUBR SYBSRH,STRADR,TABADR Symbol lookup
C00374 00054 SUBR SYBSRP,STRADR,TABADR Symbol lookup with partial match
C00378 00055 SUBR PFCONS Make a LISP cell.
C00381 00056 SUBR PFUNCS Release a LISP cell.
C00383 00057 SUBR CVPPN,STRING Convert from string to PPN
C00386 00058 SUBR CVSIX,STRING Convert to SIXBIT
C00388 00059 SUBR GETMRK Read a mark
C00391 00060 SUBR SNDMRK,MRKCOD Send a mark
C00394 00061 SUBR SNDMK2,MRKCOD,SUBCOD,STRPTR Send a marked messages
C00396 00062 SUBR PIPEIT,READOP,WRITEOP Copy from input stream to output stream
C00398 00063 GETCHR GETCH1 GETCH2 GETCH3 GETCH4 GTEDIR GTEDIL GETBYT GETCH6 PUTBYT PUTCH2
C00405 00064 CMDGET CMDCHR CMDEOF CMDCH1 CMDCH2 CMDCH3 CMDCH4 CMDBYT CMDCH6
C00409 00065 UFDWRD UFDWR6 MFDWRD MFDWR6
C00411 00066 Must preserve buffer rings during OPEN
C00413 00067 PUPGET PUPGE6 PUPGE5 pupgem PUPROP pupro2 PUPPUT PUPPU2 PUPPU4 PUPPU5 PUPWOP SETPAD
C00420 00068 PNAMTB TNAMTB NTYPNM ELNMTB ELCR ELCRLF ELTRNS NELNMS
C00423 00069 UCMTAB NUCMDS
C00426 00070 Break tables
C00428 00071 BEGZER PFLAVL RESCNT NNULLS MRKFLG BAUDRT NAMBUF NAMLEN HNAME HNAMSZ WAITSH SNBUF OLDPSW U.UNAM U.UPSW U.UACT U.DIRE U.TYPE U.EOLC U.BYTE PKTBUF PKTWSZ PKTBSZ ENDZER SRVRSW NOPRMT CMDOP SYSCMD INBLK INFILE INHDR INERRS OUTBLK OUTFIL OUTHDR OUTERRS PUPBLK PUPFIL PUPIHD PUPOHD EIBYTS EOBYTS MFDBLK MFDFIL UFDBLK UFDFIL MFDHDR UFDHDR MFDERRS UFDERRS FAKDEV UFDBUF PROBLK PROFIL HLPNAM CONBLK CONSTS CONLSK CONFSK CONHST LSNBLK LSNSTS LSNLSK LSNFSK LSNHST MSCBLK MSCSTS ERMSOP TYOPOS SDEBUG UDEBUG PKTLEN PKTTYP PKTBFD PKTLEN PKTTYP PKTBFD OLDACT NEWACT FAKEPL PDL PDLIOW
C00439 ENDMK
C⊗;
TITLE PUPFTP - FTP for the Ethernet
SUBTTL Both User and Server
;------------------------------------------------------------------------------;
;If you hack it, comment it! Otherwise don't touch. ;
; ;
;Make sure you update the version number and include a description of your ;
;changes in the History section. ;
; ;
;This program should be assembled via PREPARE @PUPFTP. It should be saved as ;
;SYS:PUPFTP.DMP, PUP003.DMP[NET,SYS], and PUP007.DMP[NET,SYS] making sure to ;
;save its symbols by explicitly specifying the core size if RAID isn't ;
;included.
; -- TVR ;
;------------------------------------------------------------------------------;
DEFINE VERINF<.TTL(SAIL,0.5C,02-Dec-86)> ;Did you make a history comment?
;Type αFHistoryα:
DEFINE .TTL(SITE,VERNUM,DATE)
<
PRINTS/
PUPFTP - FTP for a WAITS on an EtherNet. SITE version VERNUM, DATE
/>
VERINF
FTPVER←←1 ;Protocol version number (don't change this unless Xerox
; changes it).
FTPSKT←←3 ;Contact socket number.
MSCSKT←←4 ;Miscellaneous services (get host number)
FDESIZ←←20 ;Size in words of file directory entry (UFD entry size)
;IFNDEF PUP82,<↓PUP82←←1> ;Version of PUPSER
IFNDEF FTXINF,<↓FTXINF←←1>
IFNDEF FTXPWD,<↓FTXPWD←←1> ;Already read password from TTY if non-zero
;Use same definitions as MAXC uses, so other EtherNet wizards may find
;some familariness in the surroundings...
SEARCH PUPDEF
;A library used for read/wruting numbers, strings, etc. Also, define macros
;for referencing stack entries by name.
SEARCH TVRHDR
.LIBRARY TVRLIB.REL[SUB,SYS]
;------------------------------------------------------------------------------
;Things that should be defined elsewhere
;------------------------------------------------------------------------------
↓PUPCON←←0 ;PUP MTAPE code for connect (CAUTION: format is different)
↓PUPLSN←←1 ;PUP MTAPE code for listen
↓PUPSIP←←10 ;PUP MTAPE code for skip on input ready
↓PUPSMR←←25 ;PUP MTAPE code for send Mark
↓PUPRMR←←26 ;PUP MTAPE code for read Mark
↓PUPOVH←←=22 ;Number of overhead bytes in a PUP
↓IODMRK←←40000 ;I/O status bit meaning MARK seen. (Like EOF)
↓MNAMLK←←220 ;PUP Type (Misc. Services): Name Lookup Request
↓MNAMRS←←221 ;PUP Type (Misc. Services): Name Lookup Response
↓MLKERR←←222 ;PUP Type (Misc. Services): Dir. Lookup Error Reply
;Remarks and History
ifn 0,< ;Instead of COMMENT so directory page doesn't get zapped by αXNDFAIL
Remarks:
This attempts to handle a protocol designed with TENEX concepts in mind. So,
some amount of bending is required. In particular, no attempt is made to save
more than 6 characters of file name, more than 3 characters of extension, and
furthermore, the following are just plain discarded: version numbers, author,
protection, and type. If someone demands it, this cruft could be saved in a
separate file, which would then map longer file names (or especially colliding
file names) onto unique SAIL style name in such a way as to allow them to be
rewritten on with original parameter on style of machine they came from. But
I hope we don't have to do that.
The protocol is state oriented, and the code will reflect that to some degree.
Don't get too disgusted with the numerous GOTO sorts of constructions, they
reflect the structure of the protocol as much as possible.
AC usage conventions:
In general, any subroutine is expected to preserve everything except RET, RET2
and perhaps TAC and TAC2. If the latter are clobbered, this should be noted
in the description of the subroutine.
P is the general stack pointer. However, it should be used with care in
subroutines which have macros to reference stack elements. See below.
Special macros:
There are special macros use in subroutines to define arguments and local
variables which live on the stack. These are SUBR, SUBREND, LOCALS, and
ACCUMULATORS. There are a few other which maintain stack discipline:
PUSHP, POPP, PUSHACS, POPACS, CALL, and RETURN. These macros will not
work properly if you do PUSH or POP and don't adjust .PLEVEL accordingly.
Something that does a PUSH should increment .PLEVEL by one.
Search lists:
A search list is the result of compiling a file name pattern. It
specifies in a simple minded way what an interesting file might be.
An example (in a conceptual form) generated from FOO*[*,TVR],*ER*[NET,*]
would be:
((((???TVR UFD))
((FOO??? ???)))
(((NET??? UFD))
((ER ???) (?ER ???) (??ER ???) (???ER ???) (????ER ???) (?????? ER)
(?????? ?ER))))
where `?' matches any character. Actual encoding uses lists of masks.
Note the complexity introduced in conforming to the ALTO/IFS notion that a
dot is just another character. However, the complexity is correspondingly
reduced by the fact that we limit the size of file names.
and:
-------------------------------------------------------------------------------
History --
19-Dec-80 Began coding (TVR)
01-Jan-81 Reconstructed from listing file using EMACS after disk crash.
04-Jan-81 Initial server with only store and retrieve of single files.
10-Jan-81 Server directory command with hairy wild cards.
14-Jan-81 File access code adapted from ARPANet FTPSER (by request).
15-Feb-81 Mail recieving code, using FACT.TXT[SPL,SYS]. Still does not
handle mail to ARPANET or look at FORWRD.TXT[MAI,SYS].
04-Apr-81 Changed type/bytesize mechanism
07-Sep-81 Changed "via Ethernet" to "(SuNet)" and added WAKEME (ME).
22-Dec-81 Updated for new PUPSER
08-Aug-82 Fixed bug in SRSMAI, was not checking for EOL convention.
24-Nov-82 Changed default character conversion, added new type, MIT, for
version which swaps '←' and '_'.
24-Dec-82 Compensate for misfeature of UUOCON, e.g. must clear IODMRK so
output will win. STOP does RESET before EXIT 1, if detached,
to prevent incomplete files from being CLOSEd.
05-Jan-83 SRSMAI was failing if Sender was not given in each property
list. Code now defaults the sender to that last one given.
29-Jan-83 Generated 'Recieved:' field for MAIL. Includes kludge to
get host name from CONFIG in system. Includes NETWRK to get
name from host number. Sets ALIAS to host name if detached.
Added EOLC command, and a few synonyms to ELNMTB.
31-Jan-83 Fixed another bug in SYBSRH. That routine ought to be written.
Diddled ELNMTB for SYBSRH's benefit. Bulletproofing for ERRXCT.
Fixed bugs in error message in RDPROP, RDPLST, and many of those
who called RDPLST. Fixes to EOL-Convention in US/SR RETR/STOR.
03-Feb-83 Added EOLHAK to comment if server doesn't return EOL-Convention,
and use local copy.
04-Feb-83 Put back ending double quote accidentally removed along with
(SuNet). But can't compile and load successfully. -- ME
16-Feb-83 Fix at PLSTLP to increment count (TAC2) of mailboxes; fix
at MLBXER to send number of bad mailbox in (decimal) text. ME
28-Feb-83 Fixed more bugs in RDPROP. It now treats unknown properties
as warnings instead of errors.
08-Mar-83 Fixed CVPPN to ignore leading '['. PLSTNM has kludge to make
sure both halves of PPN are non-zero.
30-May-83 ME Fixed FNDUSR to ignore E directory (in \F file), not to scan
after tabs in \F, to scan \F file first, passes original
mailbox name to MAIL instead of the matching string.
14-Jun-83 ME Fix to GTHNAM to set NW%SU correctly before calling HSTNUM.
Also, accepts dotted host number HSTNUM returns if failed.
07-Oct-83 TVR Added special case check to RLPLST for P.BYTE in case other
end sends us a ridiculous byte-size which looks like an F.S.
address.
30-Oct-83 TVR Fixed FNDUSR to permit #<file> construction, and also to accept
<anything>@<anything>, figuring that MAIL can return to sending
if host is non-existent or inaccessible.
Flushed PUP82 conditionals.
17-Jun-85 JJW Fixed code in STRSL to jump to REGPPN after inserting default
project or programmer.
25-Mar-86 TVR In PLSTSL, literal following SRNMLP was dropping the first
character in a file name when Server-Name contained a device. I
guess only Symbolics used this feature or else no one complained.
14-May-86 TVR Added some missing properties to PUPDEF.MAC, but we really need a
more official copy. Flushed null padding kludges from PUPGET and
PUPPUT, etc. Fixed USRCHK so that it was actually able to check
the user password. I think more is still needed, though, in the
area of file protection. Fixes up herald with proper host name
now ('twas only adjusting the MAIL header before). Put file being
transferred in the WHO line.
21-May-86 TVR Added server debug printout to mail. Put double-quotes around
"TO" field when writing xxxxxx.FTP[RMD,SYS] (so mail forwarding
will work).
24-May-86 TVR Double-quoting the whole thing was wrong. Need to quote everything
up to last host. We look only for "@" (and hope there isn't anyone
around who still uses "%"). Changed password handling to avoid
using INF privilege. Fixed error code in PLSTNM. Misc. cleanup
to get rid of a few PRINTX's.
28-May-86 TVR Fixed bug where byte size rather than byte pointer was being
adjusted at SRSMAI&NOHOST-1.
01-Jun-86 TVR Use "optimal" (for first file at least) buffering on disk I/O,
and don't lose buffer rings on multiple OPENs(!).
03-Jun-86 TVR This quoting business is beginning to look even more like a bad
idea. Just below TOLOOP (in SRSMAI), check to see if the string
is already quoted, and if so, assume other end knows what they're
doing. Moved upper casing from SRSMAI to FNDUSR so that it
won't trash UNIX user/host names.
06-Jun-86 TVR Re-assembled with new NETWRK.
09-Jun-86 TVR Default to 36 bit binary for WAITS to WAITS. TENEX command also
sets these things. Print defaults. Fixed an old bug which
prevented version number from being printed on startup. Numerous
changes to command parsing in order to eventual take one-liners
from the command line.
24-Sep-86 TVR Added indirect file (USXIND, CMDCHR, etc.). Suspends on errors
and can be continued via XIND with no argument. Also, made EOL
checker not care if we're not transferring some kind of text.
25-Nov-86 JJW Changed normal text mode to interchange "_" and "←". Flushed
MIT mode, added SAIL mode to not do interchange (as in FTP).
28-Nov-86 TVR Noticed that SAIL's PUPFTP server says SAIL and not SU-AI. Fixed
ENDGRT to check for this instead. Fixed a couple of bugs having
to do with not calling CMDTRM (user mode XIND stuff). Updated
PUPFTP.PUB to include XIND and TENEX commands.
02-Dec-86 JJW Changed initialization code to work with SAIL's 4-char name.
History:
>;ifn 0
PRINTX Did you remember to update the version number and date?
;RET RET2 TAC TAC2 P INCHN OUTCHN PUPCHN MFDCHN UFDCHN PROCHN RCUNDF RCNOUS RCILGC RCMFPL RCILSF RCILDR RCILNB RCILVR RCILTY RCILUS RCILPS RCILAC RCILDV RCILMB RCFNF RCPROF RCFDER RCFULL RCNORE RCNOST RCTFSF RCFBSY SNNEXT SNONS SNOFFS SNSIZE
;------------------------------------------------------------------------------
;
; AC definitions
;
;------------------------------------------------------------------------------
↓RET←1 ;Normal value
↓RET2←2 ;Second value and temp.
↓TAC←3 ;Temp.
↓TAC2←4 ;Another temp.
↓P←17 ;The stack
;------------------------------------------------------------------------------
;
; Fixed I/O channels
;
;------------------------------------------------------------------------------
;Don't use channel 0, MRC will steal it from you.
↓INCHN←←1 ;Disk input
↓OUTCHN←←2 ;Disk output
↓PUPCHN←←3 ;EtherNet I/O
↓MFDCHN←←4 ;Channel for Master File Directory
↓UFDCHN←←5 ;Channel for User File Directory
↓PROCHN←←6 ;Channel used for checking protection
↓HLPCHN←←PROCHN ;Use it also for HELP
↓CMDCHN←←7 ;Command file input
;------------------------------------------------------------------------------
;
; Reply codes
;
;------------------------------------------------------------------------------
;These really should be in PUPDEF
↓RCUNDF←←1 ;Last command undefined or unimplemented.
↓RCNOUS←←2 ;Command requires User-Name to be supplied, and it wasn't
↓RCILGC←←3 ;Last command illegal in present context
↓RCMFPL←←10 ;Malformed property list
↓RCILSF←←11 ;Illegal Server-Filename
↓RCILDR←←12 ;Illegal Directory
↓RCILNB←←13 ;Illegal Name-Body
↓RCILVR←←14 ;Illegal Version
↓RCILTY←←15 ;Illegal type
↓RCILBY←←16 ;Illegal Byte-Size.
↓RCILUS←←20 ;Illegal User-Name
↓RCILPS←←21 ;Illegal or incorrect User-Password
↓RCILAC←←22 ;Illegal or incorrect User-Account
↓RCILAC←←23 ;Illegal Connect-Name
↓RCILDV←←31 ;Illegal device
↓RCNOMB←←40 ;No valid mailbox
↓RCILMB←←41 ;Illegal mailbox
↓RCILSN←←42 ;Illegal sender property
↓RCFNF←←100 ;File not found
↓RCPROF←←101 ;Requested access denied to file [Protection Failure]
↓RCTRSP←←102 ;Transfer parameters inconsistent with file parameters
↓RCFDER←←103 ;File data error
↓RCFULL←←104 ;File too long or storage full
↓RCNORE←←105 ;Do not send file (due to No from user)
↓RCNOST←←106 ;Store not completed (due to No from user)
↓RCTFSF←←107 ;Transient server or file system error
↓RCFBSY←←111 ;File busy
;------------------------------------------------------------------------------
;
; Search Node
;
;------------------------------------------------------------------------------
PHASE 0
SNNEXT::BLOCK 1 ;Pointer to next node in search list
SNONS:: BLOCK 2 ;Mask of bits which must be on
SNOFFS::BLOCK 2 ;Mask of bits which must be off
SNSIZE::
DEPHASE
;------------------------------------------------------------------------------
;
; MRKTAB
;
;The following macro generates a dispatch table for mark commands. Only the
;right half of these things is currently used, the left half contains the code
;for easier debugging. MRKTAB calls MRKTB0, which actually makes the table.
;See SRVDSP for sample call. Note that codes must be in numeric order for now.
;
;This is defined as a macro so that it might be possible to change the
;structure of these things in the future. As it stands, it generates a simple
;jump table, with undefined entries pointing to CNTXER (context error). Change
;MRKDSP if you change this.
;
;------------------------------------------------------------------------------
DEFINE MRKTAB(MARKS)<
;;; XLIST
0*1B11+BADMRK ;There ain't no mark 0
↔ .MTEMP←←1
FOR ELEMENT IN (MARKS) <
MRKTB1 ELEMENT
>;FOR
;;; LIST
>;DEFINE MRKTAB
DEFINE MRKTB1 '(NAM,DSP) <
IFL MK'NAM-.MTEMP,< .FATAL Bad MRKTAB entry NAM
>;IFL
REPEAT MK'NAM-.MTEMP,
< .MTEMP*1B11+CNTXER
↔ .mtemp←←.mtemp+1
>;REPEAT
MK'NAM*1B11+DSP
↔ .MTEMP←←MK'NAM+1 ;↔ so it doesn't show via αXNDF
>;DEFINE MRKTB1
;------------------------------------------------------------------------------
;
; MRKDSP
;
;This macro is called with a pointer to a mark table constructed by MRKTAB
;and PUSHJ's thru that table.
;
;------------------------------------------------------------------------------
DEFINE MRKDSP(AC,TABADR)
< CAIL AC,NMARKS ;Check for legal mark
PUSHJ P,[AOS (P) ;It isn't
JRST BADMRK]
PUSHJ P,@TABADR(AC) ;Dispatch
>;DEFINE MRKDSP
;------------------------------------------------------------------------------
;
; ERRARG
;
; This macro is used for arguments to WARNMSG and other error routines.
;
;------------------------------------------------------------------------------
DEFINE ERRARG '(TYPE) <<ERR'TYPE*1B12>+>
;------------------------------------------------------------------------------
;
; TYDSEN
;
; Macro used in DORCV and DOSND to make tables used to dispatch on type.
;
;------------------------------------------------------------------------------
;Dispatch table for binary types
DEFINE TYDSEN '(letter,size,label) <
XWD 1000*TYPE.'letter+=size,label
>;DEFINE
;-------------------------------------------------------------------------------
;
; Define codes for property names
;
; Macro PNAMES is courtesy of Xerox PARC and is a list of macro calls to
; X of the form <internal mnemonic>,<property name>,<size for TENEX>
;
; We use different ID codes than PARC, so we redefine P.xxxx codes.
;
;-------------------------------------------------------------------------------
DEFINE X '(SYM,NAME,SIZE) <
P.'SYM←←I ;Redefine the code for this property
PRINTS/ SYM/ ;Say something for the folks back home
IFE I&7,<PRINTS/
/> ;Break it into several lines
↔ I←←I+1 ;Advance property counter
>
↔ I←←1 ;Start with code of 1.
PRINTS/ Properties: /] ;Print what we defined.
XLIST ;Save paper. You really don't want to see all crud
PNAMES
LIST
NPNAMS←←I
PRINTS/
/ ;No more properties to print.
;------------------------------------------------------------------------------
;
; Define type names
;
; This macro is used to define internal codes for the various types and
; to construct a symbol table.
;
; Type names must remain in alphabetical order
;
;------------------------------------------------------------------------------
DEFINE TNAMES <
X A,ASCII
X B,BINARY
X D,DUMP-MODE
X I,IMAGE
X S,SAIL
X T,TEXT
X X,X
>
DEFINE X '(LETTER,NAME)
< TYPE.'LETTER←←I ;One letter type names
↔ I←←I+1
>
↔ I←←1
TNAMES ;Define internal type codes
;DRYROT WARNMS ERROR1 ERRLP ERRTAB ERREND ERRCHR ERRSIX ERROCT ERRTXT ERRCRLF ERTYPS PUPERR ;⊗ DRYROT WARNMS WARNM2 ERROR1 ERRLP ERRBUG ERRJM1 ERRJM2 ERRJM3 ERRXCT ERRTAB ERREND ERRCHR ERRSIX ERROCT ERRDEC ERRTXT ERRCRLF ERTYPS PUPERR STOP
;------------------------------------------------------------------------------
;
; Error routines
;
; Warning: ERRTAB must be assembled before ERRARG is used. Otherwise,
; FAIL fails.
;
;------------------------------------------------------------------------------
;Something horrible has happened.
DRYROT: CALL WRASCZ↑,<[[ASCIZ/
You have encountered a bug. Find a wizard if possible. /]]>,ERMSOP
JRST 4,.
POPJ P, ;Ha, ha, ha
WARNMS: PUSHJ P,ERROR1 ;Ordinary error
[ASCIZ/Warning: /]
PUSHJ P,SUSPND ;Stop command file until user is ready to proceed
POPJ P,
ERROR1: PUSHP RET ;Save two things generally clobbered by printout
PUSHP RET2
CALL WRASCZ↑,<@-2(p)>,ERMSOP
AOS -2(P)
; -3(P) Return address
; -2(P) Caller of ERROR1
; -1(P) Saved RET
; 0(P) Saved RET2
ERRLP: MOVE RET2,(P) ;Restore AC that may be printed
SKIPN RET,@-3(P)
JRST[ POP P,RET2 ;Restore ACs. Note violation of POPP
POP P,RET ; is OK here because it's a literal.
AOS -1(P) ;Skip over terminating zero
POPJ P, ] ;And we're done
LDB RET,[POINT 13,RET,12] ;Pick up opcode and AC
CAIL RET,ERTYPS ;Too big?
JRST[ MOVE RET,@-3(P) ;Yes, just XCT it after some checking
CAML RET,[JUMP]
CAMLE RET,[SOJG 17,@-1(17)]
JRST[ CAML RET,[JRST]
CAML RET,[JRST 1,]
JRST[ LDB RET,[POINT 4,@-3(P),12] ;Check AC
CAIN RET,P
ERRBUG: JRST[ OUTSTR[ASCIZ/Illegal argument to error routine! /]
MOVE RET,-1(P)
JRST 4,ERRBUG ]
MOVE RET,-3(P)
JRST ERRXCT ]
OUTSTR[ASCIZ/*** JRST in error arguments! ***/]
JRST ERRJM1 ] ;Simulate the utter loser
TLNN RET,010000 ;CAM,SKIP,AOS,SOS are OK
TLNN RET,060000 ;And so is CAI
JRST ERRXCT
; \ /
;Here we simulate a jump instruction
ERRJM1: HRRI RET,ERRJM2 ;Case where jump succeeds
PUSHP RET
MOVE RET,-2(P)
XCT (P) ;Maybe jump
AOS -3(P) ;Didn't. Do next instruction
JRST ERRJM3
; ---
ERRJM2: LDB RET,[POINT 24,@-4(P),35] ;We jumped, find out where
TLO RET,(<MOVEI RET,>) ;Instruction to execute to load RET
MOVEM RET,(P) ;wtih effective address
MOVE RET,-2(P) ;In case RET is used in address calc.
XCT (P) ;Load effective address into RET
HRRM RET,-4(P) ;It's the new PC
; \ /
ERRJM3: POPP <(P)> ;Flush stack
JRST ERRLP ;Now, what's next
; ---
ERRXCT: MOVE RET,-1(P)
XCT @-3(P)
AOSA -3(P) ;Now, advance and try again
AOSA -3(P)
JRST ERRLP
AOS -3(P)
JRST ERRLP ]
PUSHJ P,[PUSH P,ERRTAB(RET) ;Push routine to execute
MOVE RET,-3(P) ;Restore RET
POPJ P,] ;Jump to that routine
AOS -3(P) ;Advance to next word
JRST ERRLP ;Repeat until zero found.
; ---
ERRTAB:
PHASE 0
↓ERREND::DRYROT ;Buggy error message
↓ERRCHR::[PUSH P,@-4(P) ;Push pointer to character on stack
MOVE RET,@(P) ;Fetch character
POP P,(P) ;Flush stack
XCT ERMSOP ;Print character
POPJ P,]
↓ERRSIX::[PUSH P,@-4(P) ;Push pointer to value on stack
MOVE RET,@(P) ;Fetch value
POP P,(P) ;Flush stack
CALL WRSIX↑,RET,ERMSOP ;Print it in sixbit
POPJ P,]
↓ERROCT::[PUSH P,@-4(P) ;Push pointer to value on stack
MOVE RET,@(P) ;Fetch value
POP P,(P) ;Flush stack
CALL WRINT↑,RET,<[8]>,ERMSOP ;Print it in octal
POPJ P,]
↓ERRDEC::[PUSH P,@-4(P) ;Push pointer to value on stack
MOVE RET,@(P) ;Fetch value
POP P,(P) ;Flush stack
CALL WRINT↑,RET,<[=10]>,ERMSOP ;Print it in decimal
POPJ P,]
↓ERRTXT::[PUSH P,@-4(P) ;Push pointer to address on stack
MOVEI RET,@(P) ;Calculate address of string
POP P,(P) ;Flush stack
CALL WRASCZ↑,RET,ERMSOP ;Print the string
POPJ P,]
↓ERRCRLF::[MOVEI RET,15 ;Just type a <return><linefeed>
XCT ERMSOP
MOVEI RET,12
XCT ERMSOP
POPJ P,]
ERTYPS::
DEPHASE
;------------------------------------------------------------------------------
;
; Special purpose error routines
;
;------------------------------------------------------------------------------
;Error referencing EtherNet
PUPERR: PUSHJ P,ERROR1
[ASCIZ/?
Ethernet error: /]
STOP: setom ttylin# ;See if we're detached
getlin ttylin
aosn ttylin
reset ; Yes, discard any partially written files
exit 1, ;as EXIT 1, will CLOSE everything if detached.
popj p, ;Try to continue, but it probably won't work.
;START RESCN1 RESCN2 RESCN3 START0 START1 START2 PCONFIG USERBG HNMLP GETWIZ GRTLP ENDGRT UVERST TXSPRE GIVEUP INITDN
;------------------------------------------------------------------------------
;
; Initialization
;
;------------------------------------------------------------------------------
;Start at starting address plus 2 to run as a server.
START: JRST [ ;Normal starting address
SETOM SRVRSW ;Find out whether we're on a real TTY
GETLIN SRVRSW
AOSN SRVRSW ;Detached?
JRST START0 ; Yes, i am an FTP server.
RESCAN TAC ;Count characters from invocation line
MOVE TAC2,[POINT 7,SYSCMD]
RESCN1: SOSL TAC
INCHRS RET ;Get another character
JRST START1 ; None left!
CAIE RET,12 ;LF yet?
CAIN RET,175 ;Or ALT perhaps?
JRST START1 ; Yeah, do normal input business
ILDB RET2,TAC2 ;Get character from command name
CAIE RET,(RET2) ;Check character
CAIN RET,"a"-"A"(RET2) ;Check also lower case
JRST RESCN1 ; Still skipping invocation word
RESCN2: CAIN RET,";" ;Look like a command?
JRST RESCN3 ; Yes, use it!
SOSL TAC
INCHRS RET ;Get another character
JRST START1 ; None left!
CAIE RET,12 ;LF yet?
CAIN RET,175 ;Or ALT perhaps?
JRST START1 ; Yeah, do normal input business
JRST RESCN2 ;More left on invocation line
; ---
RESCN3: SETOM NOPRMT ;Skip initial prompt
JRST START1 ] ;Now, start doing something about it!
JRST START1 ;RPG starting address
; \ / !!
START0: SETOM SRVRSW ;I am a Server FTP
SKIPA
START1: SETZM SRVRSW ;I am a User FTP
MOVE RET,[PUSHJ P,CMDGET] ;Initial command stream source
MOVEM RET,CMDOP
START2: RESET
MOVE P,PDLIOWD ;Setup a stack
SETZM BEGZER ;Clear out variables initialized to zero
MOVE RET,[XWD BEGZER,BEGZER+1]
BLT RET,ENDZER
SETZM INHDR ;Clear pointers to stale buffer rings
SETZM OUTHDR
SETZM PUPIHD
SETZM PUPOHD
SETZM MFDHDR
SETZM UFDHDR
CALL FSINIT↑ ;Reset free storage system
SETZM UPPN ;Zero the junk that's defined in ACCCHK
SETZM PRIVS
SETZM PASSOK
;;; *** This kludge assumes host name is four or five characters long. Sigh. ***
PCONFIG←←227
MOVEI RET,PCONFIG
PEEK RET,
PEEK RET, ;Get first 5 chars of system name
MOVEM RET,UVERST ;Store in version strings (including space
MOVEM RET,SVERST ; at end if 4-character name)
TRNN RET,(177-40)*2
TRZ RET,40*2 ;Change space to null if no 5th char
MOVEM RET,WAITSH ;Save system name
;;; *** end of kludge
MOVEI RET,10 ;This could have been wrong if ↑C done at bad
MOVEM RET,MFDBLK ;time.
OPEN PUPCHN,PUPBLK ;Setup to use EtherNet
JRST[ CALL WARNMSG
ERRARG TXT,[ASCIZ/Can't open device PUP!/]
ERRARG CRLF,0
0
JRST GIVEUP ]
MOVEI RET,8 ;Set byte size to 8 for PUP connection
DPB RET,[POINT 6,PUPIHD+1,11]
DPB RET,[POINT 6,PUPOHD+1,11]
SKIPE SRVRSW ;Are we a server today?
JRST SRVRBG ; Yes, start taking commands
USERBG: CALL WRASCZ,<[UVERST]>,ERMSOP
CALL WRASCZ↑,<[[ASCIZ/
/]]>,ERMSOP
HNMLP: SKIPN NOPRMT ;Skip prompt due to invocation line?
OUTSTR[ASCIZ/Ethernet host: /] ;No, print it now.
SETZM NOPRMT ;Next time for sure.
CALL RDEHST,CMDOP ;Read host name (or number)
JUMPLE RET,[
;; CALL WRASCZ↑,<[[ASCIZ/Not a host name. Try again.
;;/]]>,ERMSOP
JRST HNMLP ]
MOVEM RET,CONHST ;Set host number
MOVEI RET,FTPSKT
MOVEM RET,CONFSK
SETOM CONLSK ;Use GENSYM local socket
MTAPE PUPCHN,CONBLK ;Try to establish a connection
MOVE RET,CONSTS
STATO PUPCHN,740200 ;Some kind of error?
TRNE RET,77
JRST[ CALL WRASCZ↑,<[[ASCIZ/Connection failed./]]>,ERMSOP
JRST GIVEUP ]
OUTSTR[ASCIZ/Connection established/]
MOVEI RET,TYPE.T ;Set defaults, Type Text
MOVEM RET,U.TYPE
MOVEI RET,8 ; Bytesize 8
MOVEM RET,U.BYTE
printx We'd like to set U.EOLC to avoid losing bare CRs, but it loses on ALTOs
CALL SNDMK2,<[MKVERS]>,<[FTPVER]>,<[UVERSTR]>
;Send our version number.
CALL GETMRK ;Read what better be their version information.
CAIE RET,MKVERS ;Did they reply with their version?
JRST[ PUSHJ P,WARNMSG
ERRARG TXT,[ASCIZ/Your host doesn't have a proper FTP server!/]
ERRARG CRLF,0
ERRARG TXT,[ASCIZ/They sent '/]
ERRARG OCT,RET
ERRARG TXT,[ASCIZ/ as mark code instead of version code./]
GETWIZ: ERRARG CRLF,0
ERRARG TXT,[ASCIZ/Contact an Ethernet wizard./]
0
HALT $.+1
JRST GIVEUP ]
CALL PUPGET ;Get version number
CALL UNEXMK ; Unexpected mark or EOF
CAIE RET,FTPVER ;Is it the same version?
JRST[ CALL WARNMSG
ERRARG TXT,[ASCIZ/Version number mismatch, they sent version #/]
ERRARG OCT,RET
JRST GETWIZ ] ;Don't even try to continue (see above)
OUTSTR[ASCIZ/
/] ;Signify completion
;; CALL USRLMS,<[TXSPRE]> ;Print their version information
MOVEI RET,"<"
SKIPE UDEBUG
XCT ERMSOP
MOVEI RET," "
SKIPE UDEBUG
XCT ERMSOP
MOVE TAC,[POINT 7,NAMBUF] ;Save copy of greeting.
SETZM NAMBUF
GRTLP: CALL PUPGET
JRST ENDGRT
CAME TAC,[POINT 7,NAMBUF+1,34] ;Only same two wordsworth
IDPB RET,TAC
SKIPE UDEBUG
XCT ERMSOP
JRST GRTLP
; ---
ENDGRT: MOVE RET,NAMBUF
CAMN RET,[ASCIZ/SAIL /]
JRST ISSAIL
CAMN RET,[ASCIZ/CCRMA/]
JRST[ LDB RET,[POINT 7,NAMBUF+1,6]
CAIE RET," "
JRST .+1
ISSAIL::MOVEI RET,TYPE.B
MOVEM RET,U.TYPE
MOVEI RET,=36
MOVEM RET,U.BYTE
HRRZ RET,ELNMTB+ELCRLF
MOVEM RET,U.EOLC
JRST .+1]
CALL GETMRK ;Read terminating mark
CAIN RET,MKEOC ;Terminated properly?
JRST INITDN ; Yes, we're done with initialization
CALL WARNMSG
ERRARG TXT,[ASCIZ/Protocol error: VERSION not terminated with EOC./]
ERRARG CRLF,0
0
JRST INITDN ;Try to continue, ha, ha, ha.
DEFINE .TTL(SITE,VERNUM,DATE)
< ASCIZ/SITE FTP User VERNUM/
>
UVERST: VERINF
TXSPRE: ASCIZ/< / ;Prefix for messages from foreign server.
; ---
GIVEUP: jfcl ;You might want to do something else here.
RESET ;Blast the connection, and flush any incompletely
EXIT 1, ; written files.
jrst start2 ;Resume old mode
; ---
INITDN: SKIPN UDEBUG
JRST USERLP
CALL WRASCZ↑,<[[ASCIZ/
Assuming type /]]>,ERMSOP
MOVE RET,U.TYPE
HRRZ RET,TNAMTB(RET)
CALL WRASCZ↑,RET,ERMSOP
CALL WRASCZ↑,<[[ASCIZ/, bytesize /]]>,ERMSOP
CALL WRINT↑,U.BYTE,<[=10]>,ERMSOP
CALL WRASCZ↑,<[[ASCIZ/, EOL convention /]]>,ERMSOP
SKIPN RET,U.EOLC
MOVEI RET,[ASCIZ/defaults to CR/]
CALL WRASCZ↑,RET,ERMSOP
; \ / (to next page)
;USERLP USERL1 USERL2 GOTCMD UFLUSH
;------------------------------------------------------------------------------
;
; User command loop
;
;------------------------------------------------------------------------------
; \ / (from previous page)
USERLP: OUTSTR[ASCIZ/
/]
USERL1: SKIPE NOPRMT ;Maybe not printing prompt
INSKIP 1 ;and more left on command line?
OUTSTR[ASCIZ/*/] ; No, print prompt then
SETZM NOPRMT
USERL2: CALL RDNAME,CMDOP ;Scan name of command
CAIN RET2,";" ;Comment?
JUMPE RET,UFLUSH ; Yes, ignore if first thing on line
CAIN RET2,"?" ;Wants help?
JRST[ JUMPE RET,[ CALL HELP1 ;If no name given, offer command list
JRST UFLUSH]
CALL PHELP↑,<[HLPCHN]>,<[HLPNAM]>,<[NAMBUF]>,ERMSOP,<[0]>
; Yes, let's try printing a message
JRST UFLUSH ]
CAIN RET2,"/" ;Name terminated by a switch?
JRST[ CALL WARNMSG ;Just complain for now
ERRARG TXT,[ASCIZ/Switches not implemented./]
ERRARG CRLF,0
0
JRST UFLUSH ]
CAIE RET2," " ;Name terminated normally
CAIN RET2,15
JRST[ CAIN RET2,15 ;Return?
JUMPE RET,USERL1 ; Null command.
CAIN RET2,";" ;or equivalent?
JUMPE RET,USERL1 ; Null command (???)
CAIN RET2,40 ;Space?
JUMPE RET,USERL2 ; Ignore leading spaces
PUSH P,RET2 ;Remember terminator
CALL SYBSRP,<[NAMBUF]>,<[UCMTAB]> ;Get command from name
JUMPE RET,[ ;Jump if not recoginized.
CALL WARNMSG
ERRARG TXT,[ASCIZ/Unknown command: /]
ERRARG TXT,NAMBUF
ERRARG CRLF,0
0
POP P,RET
PUSHJ P,TERRE2
JRST USERLP ]
JUMPL RET,[ ;Jump if ambigious or alternate
AOJN RET,[ ;Jump if alternate command.
MOVN RET,RET ;Unravel command
POP P,RET2
JRST GOTCMD]
CALL WARNMSG
ERRARG TXT,[ASCIZ/Ambiguous command: /]
ERRARG TXT,NAMBUF
ERRARG CRLF,0
0
POP P,RET
PUSHJ P,TERRE2
JRST USERLP ]
POP P,RET2
GOTCMD: PUSHJ P,(RET) ;Execute command
JRST USERLP ]
CAIN RET2,12 ;Bare LF?
JUMPE RET,USERL2 ; Yes, ignore if unescorted
LDB TAC,[POINT 2,RET2,35-7]
MOVE TAC,[[0]
[ASCIZ/Control-/]
[ASCIZ/Meta-/]
[ASCIZ/Control-Meta-/]](TAC)
CALL WARNMSG
ERRARG TXT,[ASCIZ/Bad command terminator: /]
ERRARG TXT,TAC
ERRARG CHR,RET2
ERRARG CRLF,0
0
MOVE RET,RET2
CALL TERRE2
JRST USERLP
; ---
UFLUSH: CALL TERREAD ;Flush rest of line
JRST USERLP
; ---
;TERREAD TERRE2 NOCRLF UGETST URELST URELS2 CMDTRM UUNIMP USQUIT
;------------------------------------------------------------------------------
;
; Misc. routines for parsing user's input
;
;------------------------------------------------------------------------------
;Consume everything up to LF, ALT, or other terminator
TERREAD:
XCT CMDOP ;Consume everything up to break character
TERRE2: CAIL RET,200 ;Control character?
POPJ P, ; Yes, that activates alright!
CAIE RET,12 ;LF?
CAIN RET,175 ;Or ALTMODE?
POPJ P, ; Yes, that's what we want
JRST TERREAD ;Flush everything else!
; ---
;General purpose message for missing a CRLF.
NOCRLF: CALL WARNMSG
ERRARG TXT,[ASCIZ/Extra input on command line./]
ERRARG CRLF,0
0
POPJ P,
;Commonly done operation. Read string and make a copy of it.
UGETST: CALL RDSTRB,<[LINBRK]>,CMDOP ;Read user name
CALL CMDTRM ;Command terminated properly?
SKIPA
JRST[ CALL COPSTR,<[NAMBUF]>
POPJ P, ]
PUSHJ P,WARNMSG
ERRARG TXT,[ASCIZ/Bad terminator: /]
ERRARG CHR,RET2
ERRARG CRLF,0
0
SETZ RET,
POPJ P,]
;Other common operation, release old string, if present.
URELST: JUMPE RET,URELS2 ;Old string?
CALL FSREL,RET ;Flush old copy
URELS2: POPJ P, ;Done.
;Check character in RET2 for command termination, and flush everpresent LF after CR.
;Skip if command successfully terminated.
CMDTRM: CAIN RET2,15
PUSHJ P,[EXCH RET,RET2
XCT CMDOP
EXCH RET,RET2
POPJ P,]
CAIN RET2,12
JRST GOTCR
CAIE RET2,";"
POPJ P,
SETOM NOPRMT
GOTCR: AOS (P)
POPJ P,
;Command not implemented yet.
UUNIMP: CALL WRASCZ,<[[
ASCIZ/Command not implemented in experimental version./]]>,ERMSOP
POPJ P,
;------------------------------------------------------------------------------
;
; QUIT
;
;------------------------------------------------------------------------------
USQUIT:
repeat 0,<
CALL SETPAD ;Make sure last output buffer is kosher
>;repeat 0
CLOSE PUPCHN, ;Try closing gracefully.
RESET ;Flush everything else hard.
EXIT
JRST START1 ;Start over
;USHELP HELP1 HELP1A HELP1B HELP1D
;------------------------------------------------------------------------------
;
; HELP <topic> (and related topics)
;
;------------------------------------------------------------------------------
USHELP: CALL CMDTRM
JRST USHLP2
; \ /
;------------------------------------------------------------------------------
;
; Print list of commands
;
;------------------------------------------------------------------------------
; \ /
HELP1: CALL WRASCZ↑,<[[ASCIZ/Commands are: /]]>,ERMSOP
MOVEI TAC,=16 ;Initial position in line
MOVEI RET2,UCMTAB+1
HELP1A: HRRZ RET,(RET2) ;Get address of command name
JUMPE RET,HELP1D ; End of table. Done
SKIPG (RET2) ;Is command special?
JRST HELP1B ; Yes. Suppress alternate command names
CALL WRASCZ,RET,ERMSOP ;Print command name
CAILE TAC,=64 ;Will the next one fit on this line?
JRST[ MOVEI TAC,=8 ; No, start new line
CALL WRASCZ,<[[ASCIZ/
/]]>,ERMSOP
JRST .+1 ]
ADDI TAC,8 ;Assume it takes this much
MOVEI RET," " ;Followed by a table
XCT ERMSOP
HELP1B: AOJA RET2,HELP1A ;Repeat for each command in table.
; ---
HELP1D:
;;; CALL WRASCZ↑,<[[ASCIZ/
;;;(Not all commands listed here are implemented.)/]]>,ERMSOP
POPJ P,
; ---
;------------------------------------------------------------------------------
;
; Print description of command
;
;------------------------------------------------------------------------------
USHLP2: CALL RDNAME,CMDOP ;Read name, if any
CALL CMDTRM ;Command terminated properly?
JRST[ CALL WRASCZ↑,<[[ASCIZ/For help, type HELP <topic><RETURN>
/]]>,ERMSOP
POPJ P, ]
LDB RET,[POINT 7,NAMBUF,6] ;Read first byte
JUMPE RET,HELP1 ; None, print command list
CALL SYBSRP,<[NAMBUF]>,<[UCMTAB]>
JUMPE RET,[ ;Jump if no match with command. Must be
;some other topic than a command.
CALL PHELP↑,<[HLPCHN]>,<[HLPNAM]>,<[NAMBUF]>,ERMSOP,<[0]>
POPJ P,]
CAMN RET,[-1]
JRST[ CALL WRASCZ↑,<[[ASCIZ/Command name is ambiguous.
/]]>,ERMSOP
JRST HELP1 ]
HRRZ RET,(RET2) ;Get command name
CALL PHELP↑,<[HLPCHN]>,<[HLPNAM]>,RET,ERMSOP,<[0]>
POPJ P,
;USTYPE USTXT2 USTEXT USTNX USBYTE USEOLC
;------------------------------------------------------------------------------
;
; TYPE Set type for transfer.
;
;Only currently types acceptable are ASCII (or TEXT) and BINARY
;(ARPANet server will accepts IMAGE and LOCAL, plus EBCDIC which earns you an
; error message.)
;------------------------------------------------------------------------------
USTYPE: CALL RDNAME,CMDOP ;Read type
CALL CMDTRM ;Command terminated properly?
JRST[ CALL WARNMSG
ERRARG TXT,[ASCIZ/Type should be terminated with <return>, not '/]
ERRARG CHR,RET2
ERRARG TXT,[ASCIZ/'/]
ERRARG CRLF,0
0
JRST UFLUSH ]
CALL SYBSRP,<[NAMBUF]>,<[TNAMTB]>
JUMPLE RET,[
CALL WARNMSG
ERRARG TXT,[ASCIZ/Unknown type: /]
ERRARG TXT,NAMBUF
ERRARG CRLF,0
0
POPJ P, ]
CAIN RET,TYPE.I
JRST[ CALL WARNMSG
ERRARG TXT,[ASCIZ/Type IMAGE not defined, use BINARY/]
ERRARG CRLF,0
0
POPJ P, ]
CAIN RET,TYPE.A ;Type ASCII is same as type TEXT
MOVEI RET,TYPE.T
;;; MOVE RET2,(RET2) ;Fetch actual symbol table entry
;;; HRRZM RET2,U.TYPE ;Set type string
MOVEM RET,U.TYPE ;Set type string
CAIE RET,TYPE.T ;Is this text?
POPJ P, ; No, we're done
USTXT2: MOVEI RET,8 ;Force byte size to 8
EXCH RET,U.BYTE
CAIN RET,8 ;Was it something else before?
POPJ P, ; No, good
CALL WARNMSG ;Tell loser we changed it.
ERRARG TXT,[ASCIZ/Byte-size set to 8./]
ERRARG CRLF,0
0
POPJ P,
;Abbreviations:
USTEXT: MOVEI RET,TYPE.T
MOVEM RET,U.TYPE
JRST USTXT2
;TENEX command is shorthand for TYPE B, BYTESIZE 36, EOL-CONVENTION CRLF.
USTNX: MOVEI RET,TYPE.B
MOVEM RET,U.TYPE
MOVEI RET,=36
MOVEM RET,U.BYTE
HRRZ RET,ELNMTB+ELCRLF
MOVEM RET,U.EOLC
SKIPN UDEBUG
POPJ P,
CALL WRASCZ↑,<[[ASCIZ/(Type BINARY, Bytesize 36, EOLC is CRLF)
/]]>,ERMSOP
POPJ P,
;------------------------------------------------------------------------------
;
; BYTE Set byte size.
;
;------------------------------------------------------------------------------
USBYTE: pushp 0
CALL RDINT↑,<[=10]>,CMDOP ;Read byte size
exch 0,(p)
popp RET2
CALL CMDTRM ;Command terminated properly?
JRST[ CALL NOCRLF ; CRLF expected here
POPJ P,] ; Flush it.
MOVE RET2,U.TYPE ;Get byte of transfer
CAIN RET2,TYPE.T ;Text?
JRST[ CAIE RET,8 ; Yes, only one bytesize possible
JRST[ CALL WARNMSG
ERRARG TXT,[ASCIZ/Only byte size of 8 is permitted for text./]
ERRARG CRLF,0
0
POPJ P,]
MOVEM RET,U.BYTE ;Set bytesize in case someone goofed
POPJ P, ] ;We don't have to do anything here.
MOVN RET2,RET ;Check mask of legal types
MOVSI RET,400000
LSH RET,1(RET2) ;Bit 0 = bytesize 1, bit 35 = bytesize 36
MOVN RET2,RET2 ;Restore byte size
; 1 2 3 4 5 6 7 8 9..15 16 17..31 32 36
TDNN RET,[BYTE (1) 0,0,0,0,0,0,0,1 (7) 0 (1) 0 (15) 0 (1) 1,0,0,0,1]
JRST[ PUSHJ P,WARNMSG
ERRARG TXT,[ASCIZ/Illegal or unimplemented byte size: /]
ERRARG DEC,RET2
ERRARG CRLF,0
0
POPJ P, ]
MOVEM RET2,U.BYTE ;Set user byte size
POPJ P,
;------------------------------------------------------------------------------
;
; EOLC Set end of line convention
;
;------------------------------------------------------------------------------
USEOLC: CALL RDNAME,CMDOP ;Read type
CALL CMDTRM ;Command terminated properly?
JRST[ CALL WARNMSG
ERRARG TXT,[ASCIZ/EOL-Convention should be terminated with <return>, not '/]
ERRARG CHR,RET2
ERRARG TXT,[ASCIZ/'/]
ERRARG CRLF,0
0
JRST UFLUSH ]
CALL SYBSRP,<[NAMBUF]>,<[ELNMTB]>
JUMPLE RET,[
CALL WARNMSG
ERRARG TXT,[ASCIZ/Unknown EOL-Convention: /]
ERRARG TXT,NAMBUF
ERRARG CRLF,0
0
POPJ P, ]
HRRZ RET,ELNMTB(RET) ;Get official name from value
MOVEM RET,U.EOLC ;Set type string
POPJ P,
;USUSER USUSR5 USACCT USALIA
;------------------------------------------------------------------------------
;
; USER Set user name. Also read password.
;
;------------------------------------------------------------------------------
USUSER: CALL UGETST ;Read line and copy if OK
JUMPE RET,[POPJ P,]
EXCH RET,U.UNAM ;Save new user name.
CALL URELST ;Flush old one.
MOVE RET,CMDOP ;Do we really have to do this B.S.?
IFE FTXPWD,<
CAME RET,[PUSHJ P,CMDGET]
JRST[ CALL UGETST ;No, take the easy way at (a fool put
; a password in a file.
JRST USUSR5]
>;IFE FTXPWD
;Following code was stolen from ARPANET FTP (i.e. TELNET[CSP,SYS]), except for
;code within FTXPWD. I don't claim to understand it, and don't want to.
PTJOBX [0↔3] ;NO ECHO
HRROI RET,[030000,,1] ;TTYSET NO PEEK INPUT BUFFER
TTYSET RET,
LEYPOS 1400 ;NO LINE EDITOR
OUTSTR [ASCIZ /Password: /] ;ASK FOR PASSWORD
IFN FTXPWD,<
pushp cmdop ;*** No passwords in files, please.
move ret,[pushj p,cmdget]
movem ret,cmdop
>;IFN FTXPWD
call ugetst
IFN FTXPWD,<
popp cmdop
>;IFN FTXPWD
pushp ret
OUTSTR [ASCIZ /
/]
HRROI RET,[10000,,] ;Suppress Control-CR once only
TTYSET RET,
LEYPOS 0 ;RESTORE THE WORLD
PTJOBX [0↔4]
HRROI RET,[030000,,0] ;TTYSET OK PEEK INPUT BUFFER
TTYSET RET,
popp ret
;End stolen code.
USUSR5: EXCH RET,U.UPSW ;Save new user password. I sure wish
;the stupid Ethernet won't require this
;for every transfer.
JRST URELST ;Flush old one.
;------------------------------------------------------------------------------
;
; ACCOUNT Set user account.
;
;------------------------------------------------------------------------------
USACCT: CALL UGETST ;Read line and copy if OK
JUMPE RET,[POPJ P,]
EXCH RET,U.UACT ;Save new user name.
JRST URELST
;------------------------------------------------------------------------------
;
; ALIAS Set directory name.
;
;------------------------------------------------------------------------------
USALIA: CALL UGETST
JUMPE RET,[POPJ P,]
EXCH RET,U.DIRE ;Save new default directory
JRST URELST
;⊗ USXIND CHGCMD SETCMD
;------------------------------------------------------------------------------
;
; XIND Indirect file
;
;------------------------------------------------------------------------------
USXIND: CALL CMDTRM ;Empty line?
JRST CHGCMD ; No, request new file
SKIPE XINDSW ;Do we already have one active?
JRST SETCMD
CALL WARNMSG ; No
ERRARG TXT,[ASCIZ/No indirect file open./]
ERRARG CRLF,0
0
POPJ P,
; ---
CHGCMD: CALL RDIOSP↑,<[CMDBLK+1]>,CMDOP,<[0]>
JRST[ CALL WARNMSG ; No
ERRARG TXT,[ASCIZ/No indirect file given./]
ERRARG CRLF,0
0
POPJ P, ]
EXCH RET,RET2 ;File name properly terminated?
CALL CMDTRM
JRST[ CALL WARNMSG ; No
ERRARG TXT,[ASCIZ/Bad terminator for indirect file: '/]
ERRARG CHR,RET2
ERRARG TXT,[ASCIZ/'/]
ERRARG CRLF,0
0
POPJ P, ]
MOVE RET,[PUSHJ P,CMDCHR]
CAME RET,CMDOP ;Already open?
JRST USXIN2
SETZM XINDSW ;Careful, only one level of command files!
call wrascz↑,<[[asciz/*** Switching to /]]>,ermsop
call wriosp↑,<[cmdblk+1]>,ermsop
call wrascz↑,<[[asciz/ ***
/]]>,ermsop
MOVE RET,[PUSHJ P,CMDGET]
MOVEM RET,CMDOP
; \ /
USXIN2: OPEN CMDCHN,CMDBLK ;Setup device
JRST[ CALL WARNMSG
ERRARG TXT,[ASCIZ/Cannot open device: /]
ERRARG SIX,CMDBLK+1
ERRARG CRLF,0
0
POPJ P,]
MOVE RET,CMDFIL+3
LOOKUP CMDCHN,CMDFIL ;Setup device
JRST[ CALL WARNMSG
ERRARG TXT,[ASCIZ/Cannot open file: /]
0
CALL WRIOSP↑,<[CMDBLK+1]>,ERMSOP
CALL WRASCZ↑,<[[ASCIZ/
/]]>,ERMSOP
POPJ P,]
EXCH RET,CMDFIL+3
SETOM XINDSW ;Indicate that we have a file open
; \ /
;We have an input file open for commands. Now select it.
SETCMD: MOVE RET,[PUSHJ P,CMDCHR]
MOVEM RET,CMDOP
POPJ P,
;Suspend processing of command file.
SUSPND: PUSHP RET
MOVE RET,[PUSHJ P,CMDCHR] ;Command file open?
CAME RET,CMDOP
JRST WARNM2 ; No, forget it.
call wrascz↑,<[[asciz/*** Command file suspended ***
/]]>,ermsop
MOVE RET,[PUSHJ P,CMDGET]
MOVEM RET,CMDOP
; \ /
WARNM2: POPP RET
POPJ P, ;Return to user.
;SRVRBG SRVRB2 SRVRB3 SRVRLP SRVDSP SRRENA NOTSUP
;------------------------------------------------------------------------------
;
; FTP Server Mode
;
;------------------------------------------------------------------------------
SRVRBG: SETZ RET, ;Were we invoked by the system?
GETNAM RET,
MOVEI RET+2,FTPSKT ;ICP socket, default unless overwise specified
TDC RET,['PUP000'] ;Magic job name?
TDNE RET,[XWD 777777,707070]
JRST SRVRB3
; \ /
;Socket number is in lower three characters of job name.
MOVEI TAC,3 ;Cheap conversion from SIXBIT to numeric
SRVRB2: ROTC RET,-3
ROT RET,-3
SOJG TAC,SRVRB2
LDB RET+2,[POINT 9,RET+1,8]
MOVE RET,['E.FTPS'] ;Set permanent job name
SETNAM RET,
SRVRB3:
MOVEM RET+2,LSNLSK ;Set socket number
SETOM LSNHST ;Any host number
SETOM LSNFSK ;Use GENSYM local socket
MTAPE PUPCHN,LSNBLK ;Try to establish a connection
MOVE RET,LSNSTS
STATO PUPCHN,740000 ;Some kind of error?
TRNE RET,77
JRST[
repeat 0,< STATZ PUPCHN,IODTMO ;Timeout?
JRST[ SETOM RET ;Yes, running detached?
GETLIN RET
JUMPL RET,GIVEUP ; Yes, flush it
JRST SRVRB3 ] ;No, keep trying
>;repeat 0 (formerly IFE PUP82)
PUSHJ P,PUPERR
ERRARG TXT,[ASCIZ/Listen failed./]
ERRARG CRLF,0
0
JRST GIVEUP ]
CALL GTHNAM,LSNHST ;Get name of host
OUTSTR[ASCIZ/Connected to /]
OUTSTR HNAME
;; SKIPN HNAME ;;no longer needed since HSTNUM returns dotted
;; OUTSTR[ASCIZ/?/] ;; host number if can't find name
OUTSTR[ASCIZ/
/]
SRVRLP: CALL GETMRK ;Get next MARK from PUP connection
MRKDSP RET,SRVDSP ;Dispatch on mark code
JRST SRVRLP
SRVDSP: MRKTAB <<RETR,SRRETR>,<STOR,SRSTOR>,<EOC,EOCSNK>,<COMM,SRCOMM>
,<VERS,SRVERS>,<NSTO,SRNSTO>,<DIR,SRDIR>,<YUSR,SRYUSR>
,<ABOR,NOTSUP>,<DELE,SRDELE>,<RENA,SRRENA>,<SMAI,SRSMAI>
,<RMAI,NOTSUP>,<FMAI,NOTSUP>>
SRRENA:
printx Rename still not supported!
; \ /
;Feature is not supported here.
NOTSUP: CALL SNDMK2,<[MKNO]>,<[RCUNDF]>,<[[ASCIZ/Not supported yet in experimental FTP/]]>
POPJ P,
;SRYUSR SRVERS SVERST SRCOMM
;------------------------------------------------------------------------------
;
; You-Are-User: Tell them we don't need anything from them
;
;------------------------------------------------------------------------------
SRYUSR: CALL SNDMK2,<[MKNO]>,<[0]>,<[[ASCIZ/No thanks, we do not need anything./]]>
POPJ P,
;;; CALL SNDMRK,<[MKYES]>,<[0]>
;;; CALL WRASCZ↑,<[[ASCIZ/Thanks. We assume you are Server now./]]>,<[PUSHJ P,PUPPUT]>
;;; SETZM SRVRSW ;We aren't server anymore
;;; POPJ P,
;------------------------------------------------------------------------------
;
; Version: Return our version number information
;
;------------------------------------------------------------------------------
SRVERS: CALL PUPGET ;Get version number
CALL UNEXMK ; Unexpected mark or EOF
CAIE RET,FTPVER ;Is it the same version?
JRST[ CALL WARNMSG
ERRARG TXT,[ASCIZ/Version number mismatch, they sent version #/]
ERRARG OCT,RET
ERRARG CRLF,0
0
JRST GIVEUP ] ;Don't even try to continue
CALL SRVLMS,<[[ASCIZ/Foreign host: /]]>
;Log or flush message
CALL SNDMK2,<[MKVERS]>,<[FTPVER]>,<[SVERSTR]>
CALL GETMRK ;Read terminating mark
CAIN RET,MKEOC ;Terminated properly?
POPJ P, ; Yes, we're done
CALL WARNMSG
ERRARG TXT,[ASCIZ/VERSION not terminated with EOC./]
ERRARG CRLF,0
0
POPJ P, ;Try to continue, ha, ha, ha.
DEFINE .TTL(SITE,VERNUM,DATE)
< ASCIZ/SITE FTP Server VERNUM/
>
SVERST: VERINF
;------------------------------------------------------------------------------
;
; Comment: We don't expect a user FTP to generate these
;
;------------------------------------------------------------------------------
SRCOMM: CALL WRASCZ↑,<[[ASCIZ/User FTP sent a comment: /]]>,ERMSOP
;Output on the error channel.
CALL PIPEIT,PUPROP,ERMSOP
;Copy from input stream to output stream
CALL WRASCZ↑,<[[ASCIZ/
/]]>,ERMSOP ;Which terminates comment.
POPJ P,
;BADMRK CNTXER NOEOC EOCSNK CLOSED
;------------------------------------------------------------------------------
;
; Errors in FTP protocol
;
;------------------------------------------------------------------------------
;We recieved a mark we don't understand, which we assume is garbage.
BADMRK: CALL WARNMSG ;Illegal MARK
ERRARG TXT,[ASCIZ/Recieved bad MARK code: /]
ERRARG OCT,RET
ERRARG CRLF,0
0
POPJ P, ;Try to ignore it.
;We recieved a mark which we did not expect, probably because it illegal in the
;current context.
CNTXER: CALL WARNMSG ;Illegal MARK
ERRARG TXT,[ASCIZ/MARK code '/]
ERRARG OCT,RET
ERRARG TXT,[ASCIZ/ illegal or unexpected in this context./]
ERRARG CRLF,0
0
CALL SNDMK2,<[MKNO]>,<[RCILGC]>,<[[ASCIZ/MARK code illegal or unexpected in this context./]]>
CNTXR2: SKIPE SRVRSW
POPJ P, ;Try to ignore it.
CALL WRASCZ↑,<[[ASCIZ/Continuing, but expect things to be confused...
/]]>,ERMSOP
POPJ P,
;We got a mark or EOF while reading a reply code.
UNEXMK: CALL WARNMSG
ERRARG TXT,[ASCIZ/Protocol error, recieved MARK or EOF instead of reply code./]
ERRARG CRLF,0
0
JRST CNTXR2 ;Tell user (s)he is about to become wedged.
;We recieved another mark when we were expecting an EOC
NOEOC: CALL WARNMSG ;Illegal MARK
ERRARG TXT,[ASCIZ/Protocol error, MARK code '/]
ERRARG OCT,RET
ERRARG TXT,[ASCIZ/ recieved instead of EOC./]
ERRARG CRLF,0
0
CALL SNDMK2,<[MKCOMM]>,<[0]>,<[[ASCIZ/Protocol lossage: Inserting missing EOC./]]>
setom mrkflg ;*** Cause current mark to be re-read
POPJ P,
;Something to consume extra EOC's
EOCSNK: CALL WARNMSG
ERRARG TXT,[ASCIZ/Flushing spurious EOC/]
ERRARG CRLF,0
0
POPJ P,
;------------------------------------------------------------------------------
;
; Connection closed. Clean up.
;
;------------------------------------------------------------------------------
CLOSED: SKIPN SDEBUG ;Always print message if debugging
SKIPN SRVRSW ;Are we a server?
JRST[ CALL WARNMSG ; No, print mesage
ERRARG TXT,[ASCIZ/Connection closed./]
ERRARG CRLF,0
0
JRST .+1]
RELEASE OUTCHN,3 ;Flush hard whatever we were writing.
JRST GIVEUP ;And leave
SUBR SRRETR ;Server Retrieve (also SRDELE)
;------------------------------------------------------------------------------
;
; Retrieve - Find file and perhaps retrieve it.
;
;------------------------------------------------------------------------------
ACCUMULATOR{T1,T2,FL,PL} ;T1,T2 clobbered by ACCCHK
CRLFSW←←1B33
DELESW←←1B34
SEENSW←←1B35
TDZA RET,RET ;No flags for retrieve
↑SRDELE: MOVEI RET,DELESW ; Doing delete, not retrieve
LOCALS{SRCLST}
PUSHP T1
PUSHP T2
PUSHP FL ;Save accumulator, local must be in AC
PUSHP PL
MOVEM RET,FL ;Set initial flags
CALL RDPLST,PUPROP ;Read property list
JUMPE RET,[TLNN RET2,-1 ;Is there an error message?
HRLI RET2,[ASCIZ/Empty property list./] ;No, make one
HLRZ RET,RET2
PUSHJ P,WARNMSG
ERRARG TXT,TXFHSN
ERRARG TXT,<@RET>
ERRARG TXT,[ASCIZ/ Terminator = /]
ERRARG CHR,RET2
ERRARG CRLF,0
0
CALL SNDMK2,<[MKNO]>,<[RCMFPL]>,RET
CALL GETMRK ;Get next mark
CAIE RET,MKEOC ;End of command?
CALL NOEOC ; Ooops.
RETURN] ;OK to just return, AC's not clobbered yet.
MOVEM RET,PL
CALL GETMRK ;Get next mark
CAIE RET,MKEOC ;End of command?
CALL NOEOC ; Ooops.
CALL PLSTSL,PL ;Get search list from property list
JUMPE RET,[CALL SNDMK2,<[MKNO]>,<[RCILSF]>,<[
[ASCIZ/No match possible, probably filename too long./]]>
CALL SNDMRK,<[MKCOMM]>
;;; MOVEI RET,0
;;; XCT PUPWOP
CALL WRASCZ↑,<[[ASCIZ/Expecting XXXXXXX.YYY[PRG,PRJ]/]]>,PUPWOP
JRST DONE]
JUMPL RET,[
MOVN RET,RET ;Error, convert to reply code
CALL SNDMRK,<[MKNO]> ;Construct complaint.
XCT PUPWOP
CALL WRASCZ↑,RET2,PUPWOP
CALL SNDMRK,<[MKEOC]>
JRST DONE ]
MOVEM RET,SRCLST ;Save search list
MOVEM RET2,MFDBLK+1 ;Set device name
MOVEM RET2,UFDBLK+1
MOVEM RET2,INBLK+1
MOVEM RET2,FAKDEV ;For SNDLPL to print device.
CALL CHKDEV,INBLK+1 ;Check legality of device
JUMPL RET,[MOVN RET,RET ;Bad device, convert to reply code
BADDEV: CALL SNDMRK,<[MKNO]> ;Illegal device
XCT PUPWOP
CALL WRASCZ,RET2,PUPWOP
CALL WRSIX,INBLK+1,PUPWOP
CALL SNDMRK,<[MKEOC]>
JRST DONE]
TLNN RET2,1 ;Can it do input?
JRST[ MOVEI RET2,[ASCIZ/Device can't do input: /]
MOVEI RET,RCILDV
JRST BADDEV ]
MOVEM RET,INBLK ;Set device status for file access
EXCH RET,MFDBLK ;Temp. set status for first LOOKUP
CALL MFDOPN ;Open device
JRST[ MOVEM RET,MFDBLK ;Restore status
CALL SNDMRK,<[MKNO]>
MOVEI RET,RCILDV
XCT PUPWOP
CALL WRASCZ↑,<[[ASCIZ/Cannot open device: /]]>,PUPWOP
CALL WRSIX↑,INBLK+1,PUPWOP
CALL SNDMRK,<[MKEOC]>
JRST DONE ]
MOVEM RET,MFDBLK ;Restore status
CALL UFDOPN ;Do OPEN a second time
PUSHJ P,DRYROT ; This can't happen for any normal device.
MOVE RET,MFDFIL ;MFD has strange property of filename=ppn
MOVEM RET,MFDFIL+3
CALL PLGET,PL,<[P.EOLC]> ;Is there a type property?
CAIE RET,ELTRNS
CAIN RET,ELCRLF
TROA FL,CRLFSW
TRZ FL,CRLFSW
MOVEI RET,MFDCHN
printx We crash here if we reference a UDP that isn't mounted.
;;; That is, if no pack is mounted, we can get "UDP offline or write locked",
;;; and there's no obvious way of finding out if there is a pack there other
;;; than doing an absolute read (which requires INFPRV)
NOTUDP: LOOKUP MFDCHN,MFDFIL
JRST[ CALL SNDMRK,<[MKNO]>
MOVEI RET,RCILDV
XCT PUPWOP
CALL WRASCZ↑,<[[ASCIZ/Not a directory device: /]]>,PUPWOP
CALL WRSIX↑,INBLK+1,PUPWOP
CALL SNDMRK,<[MKEOC]>
JRST DONE ]
CALL CHKPRO,PL,<[MFDBLK+1]>,<[A.STAT]>
;Check protection to get side effect of verifying
;user name. GOTUFD will do the rest.
MOVE RET,SRCLST ;Make special case check for single PPN
SETCM RET2,SNOFFS(RET) ;Look at file name only
CAMN RET2,SNONS(RET)
JRST[ MOVEM RET2,UFDBUF ;Set name of UFD
HLRZ RET2,SNNEXT(RET) ;Get list of files under it
JUMPE RET2,DIRTRM ;"Can't happen"
HRRZ RET,(RET) ;Is there more than one UFD on this list?
JUMPN RET,.+1 ; Yes, probably must search MFD (sigh...)
CALL GOTUFD,SRCLST ;Search this UFD
JRST DIRTRM ]
CALL MAPSL,SRCLST,<[PUSHJ P,MFDWRD]>,<[GOTUFD]>
;For each matching directory...
DIRTRM: TRNN FL,SEENSW ;Anything seen?
JRST[ CALL SNDMK2,<[MKNO]>,<[RCFNF]>,<[[ASCIZ/No such file(s)./]]>
JRST DONE]
CALL SNDMRK,<[MKEOC]> ;Terminate list of files.
; \ /
DONE: CALL RLPLST,PL ;Recover space from property list
SKIPN SRCLST ;Recover space from search list
JRST FINIS
CALL RLSL,SRCLST ;Recover space from search list
RELEASE MFDCHN, ;Don't need to reference these anymore
RELEASE UFDCHN, ;Don't need to reference these anymore
; \ /
FINIS: POPP PL ;Restore borrowed ACs
POPP FL
POPP T2
POPP T1
RETURN
;Found a UFD, search it (one argument on the stack)
;(CAUTION: You can't make symbolic stack references here.)
GOTUFD: MOVE RET,UFDBUF ;Copy parameters for LOOKUP
MOVEM RET,UFDFIL
MOVE RET,MFDFIL ;Reset PPN for all needing
MOVEM RET,UFDFIL+3
HLRZ RET,@-1(P) ;Get sublist
JUMPE RET,[pushj p,dryrot ;No files: "Can't happen"
JRST GOTUF9] ;None, ignore this
LOOKUP UFDCHN,UFDFIL ;Open the UFD
JRST[ MOVEI TAC,[ASCIZ/Directory not found: /]
ILUFDR: CALL SNDMRK,<[MKCOMM]> ;Put out a comment for LOOKUP failure
;;; MOVEI RET,0
;;; XCT PUPWOP
CALL WRASCZ↑,TAC,PUPWOP ;Send out remark indicating lossage.
HLRZ RET,UFDFIL
CALL WRSIX,RET,PUPQCK
MOVEI RET,","
XCT PUPWOP
HRRZ RET,UFDFIL
CALL WRSIX,RET,PUPQCK
JRST GOTUF9 ]
IOPUSH UFDCHN,0 ;Move into channel used to do protection checking
PUSHJ P,DRYROT ; "Can't happen"
IOPOP PROCHN,0
PUSHJ P,DRYROT ; "Can't happen"
MOVE RET2,UFDFIL ;PPN of directory to check
MOVEI TAC,A.READ ;Can we read the UFD?
PUSHJ P,GRPCHK ;Decide if we have owner access to UFD
IOPUSH PROCHN,0 ;Move back into normal place
PUSHJ P,DRYROT ; "Can't happen"
IOPOP UFDCHN,0
PUSHJ P,DRYROT ; "Can't happen"
MOVE RET,UFDFIL+2 ;Setup protection
PUSHJ P,ACCCHK ;Check for access at all
JRST[ MOVEI TAC,[ASCIZ/Directory protected: /]
JRST ILUFDR ]
HLRZ RET,@-1(P) ;Get sublist again.
CALL MAPSL,RET,<[PUSHJ P,UFDWRD]>,<[GOTFIL]>
;For each matching file in directory...
GOTUF9: POP P,-1(P) ;Flush one argument and return.
POPJ P,
;Got a file. Print information about it. (CAUTION: You can't make symbolic
;stack references here.)
GOTFIL: MOVE RET,[XWD UFDBUF,INFILE]
BLT RET,INFILE+2 ;Copy file for LOOKUP block
MOVE RET,UFDFIL
MOVEM RET,INFILE+3 ;Fill in PPN
MOVN RET,UFDBUF+4 ;Make it look like a LOOKUP block
MOVSM RET,UFDBUF+3 ;See, it's a negative swapped word count!
TRNE FL,DELESW ;Deleting?
SKIPA RET,[A.DELET] ; Yes, needs different protection check.
MOVEI RET,A.READ
CALL CHKPRO,PL,<[INBLK+1]>,RET
JUMPN RET,[ ;Can we access this for reading?
PUSHP RET2 ;Save message
;; CALL SNDMRK,<[MKNO]>
CALL SNDMRK,<[MKCOMM]>
;;; XCT PUPWOP
EXCH RET,(P) ;Restore string, save code
CALL WRASCZ↑,RET,PUPWOP
POPP RET ;Get back code
CAIN RET,RCILUS ;Bad user name?
JRST[ CALL PLGET,PL,<[P.UNAM]> ;Yes, print offender
CALL WRASCZ↑,RET,PUPWOP
JRST SKPFIL ]
CALL WRIOSP↑,<[INBLK+1]>,PUPWOP
JRST SKPFIL ] ;A rather hard failure. Too bad.
CALL INOPEN ;Try OPENing the device first
JRST[ CALL SNDMRK,<[MKCOMM]>
;;; MOVEI RET,RCILDV
;;; XCT PUPWOP
CALL WRASCZ↑,<[[ASCIZ/Device /]]>,PUPWOP
CALL WRSIX↑,INBLK+1,PUPWOP
CALL WRASCZ↑,<[[ASCIZ/ busy??/]]>,PUPWOP
JRST SKPFIL ]
MOVE RET,INFILE+3 ;Save PPN
LOOKUP INCHN,INFILE
printx We could be more specific about LOOKUP failures.
JRST[ MOVEM RET,INFILE+3 ;Restore PPN
RELEASE INCHN, ;Flush device
;; CALL SNDMRK,<[MKNO]>
CALL SNDMRK,<[MKCOMM]>
;;; MOVEI RET,RCFNF
;;; XCT PUPWOP
CALL WRASCZ↑,<[[ASCIZ/In directory but LOOKUP failed: /]]>,PUPWOP
SNDFSK: CALL WRIOSP↑,<[INBLK+1]>,PUPWOP
JRST SKPFIL ]
MOVEM RET,INFILE+3 ;Restore PPN
CALL SNDMRK,<[MKPLST]> ;Send prefix
TRNN FL,CRLFSW
SKIPA RET,[SNDCR] ;Send (EOL-Convention CR)
MOVEI RET,SNDCRLF ;Send (EOL-Convention CRLF)
CALL SNDLPL,<[INBLK+1]>,RET ;Send propery list for their approval
CALL SNDMRK,<[MKEOC]>
SKIPN SDEBUG ;Debugging?
JRST REMRK1 ; No, don't print anything
TRNE FL,DELESW ;Print message, depending on type of operation
SKIPA RET,[[ASCIZ/Delete of /]]
MOVEI RET,[ASCIZ/Retrieve of /]
CALL WRASCZ↑,RET,ERMSOP
CALL WRIOSP,<[INBLK+1]>,ERMSOP
CALL WRASCZ↑,<[[ASCIZ/
/]]>,ERMSOP
REMRK1: CALL GETMRK ;Wait for response
CAIN RET,MKNO ;Skip it?
JRST[ RELEASE INCHN, ;Flush file
CALL PUPGET ;Yes, ignore reply code
CALL UNEXMK ; Unexpected mark or EOF
CALL SRVLMS,<[[ASCIZ/File skipped: /]]>
CALL GETMRK
CAIE RET,MKEOC
CALL NOEOC
JRST SKPFIL ] ;Note, don't send EOC, might be more files
CAIN RET,MKCOMM ;Remark?
JRST[ CALL SRVLMS,<[[ASCIZ/Comment: /]]>
JRST REMRK1]
CAIE RET,MKYES ;It better be a YES if it's not a NO
JRST[ RELEASE INCHN, ;Flush file
CALL CNTXER
JRST SKPFIL ]
CALL SRVLMS,<[[ASCIZ/File accepted: /]]>
CALL GETMRK
CAIE RET,MKEOC
CALL NOEOC
TRNE FL,DELESW ;Deleting?
JRST[ RENAME INCHN,[0↔0↔0↔0] ;Yes, delete file.
printx Need to return better indication of failure of DELETE.
JRST[ RELEASE INCHN,
CALL SNDMRK,<[MKCOMM]>
;;; MOVEI RET,RCFBSY ;Usual reason is file is in use.
;;; XCT PUPWOP
CALL WRASCZ↑,<[[ASCIZ/Deletion failed: /]]>,PUPWOP
JRST SNDFSK ]
MOVEI RET2,[ASCIZ/File deleted: /] ;Setup message
JRST FILDON ] ;Success, skip file transfer code
CALL PLGET,PL,<[P.EOLC]> ;Get end of line convention
SETOM RET2 ;Assume CR
CAIE RET,ELCRLF ;CRLF
CAIN RET,ELTRNS ; or Transparent?
SETZM RET2 ; Yes, don't convert
REPEAT 0,<
CALL SNDMRK,<[MKFILE]>
PUSHP INERRS ;Save current error count
CALL DOSND,RET2,<[0]>
POPP RET2
CAME RET2,INERRS ;Did we get any errors?
JRST[ CALL SNDMK2,<[MKNO]>,<[RCFDER]>,<[[ASCIZ/File data error./]]>
RELEASE INCHN,
JRST SKPFIL ]
MOVEI RET2,[ASCIZ/Text retrieve complete: /]
>;REPEAT 0
PUSHP RET2 ;Save CR flag
CALL PLGET,PL,<[P.TYPE]> ;Get type of transfer
JUMPE RET,[ ;None specified, indicate default
CALL SNDMRK,<[MKCOMM]>
CALL WRASCZ,<[[ASCIZ/Assuming Type Text/]]>,PUPWOP
MOVEI RET,TYPE.T ;Invent code for it
JRST .+1]
LSH RET,9 ;Shift into position for DOSND
PUSHP RET ;Save on stack while getting bytesize
CALL PLGET,PL,<[P.BYTE]> ;Get bytesize for transfer
IOR RET,(P) ;Include type code
POPP <(P)> ;Flush type code from stack
POPP RET2 ;Get back CR flag
CALL SNDMRK,<[MKFILE]> ;Get ready to send actual file
CALL DOSND,RET2,RET ;Now, send file according to prepared modes
JUMPE RET,FILDON ;Jump if no errors
printx Is NO being handled properly on Server Retrieve
CALL SNDMK2,<[MKNO]>,RET,RET2 ;Send error indication
JRST FILDN2 ;And we're done
; ---
;Common code for success of retrieve or delete. Message in RET2
FILDON: CALL SNDMRK,<[MKYES]> ;Send indication of success
MOVEI RET,0
XCT PUPWOP
CALL WRASCZ↑,RET2,PUPWOP
CALL WRIOSP,<[INBLK+1]>,PUPWOP
; \ /
;Print message in RET2 for debugging and release file
FILDN2: SKIPN SDEBUG ;Debugging?
JRST FILDN3 ; No, be quiet
CALL WRASCZ↑,RET2,ERMSOP
CALL WRASCZ↑,<[[ASCIZ/
/]]>,ERMSOP
FILDN3: RELEASE INCHN,
; \ /
SKPFIL: TRO FL,SEENSW ;Indicate we've seen a file.
POP P,-1(P) ;Flush one argument and return
POPJ P,
SUBREND SRRETR
SUBR SRNSTO ;Server Store, Both styles (include SRSTOR)
;------------------------------------------------------------------------------
;
; New Store - Put file from local file system
;
;------------------------------------------------------------------------------
TDZA RET,RET ;Select new form
↑SRSTOR: SETO RET, ;Select old form
LOCALS{PLST,NEWFLG}
SETCAM RET,NEWFLG
CALL RDPLST,PUPROP ;Read property list
JUMPE RET,[TLNN RET2,-1 ;Is there an error message?
HRLI RET2,[ASCIZ/Empty property list./] ;No, make one
HLRZ RET,RET2
PUSHJ P,WARNMSG
ERRARG TXT,TXFHSN
ERRARG TXT,<@RET>
ERRARG TXT,[ASCIZ/ Terminator = /]
ERRARG CHR,RET2
ERRARG CRLF,0
0
CALL SNDMK2,<[MKNO]>,<[RCMFPL]>,RET
CALL GETMRK ;Get next mark
CAIE RET,MKEOC ;End of command?
CALL NOEOC ; Ooops.
RETURN] ;OK to just return, AC's not clobbered yet.
MOVEM RET,PLST
CALL GETMRK ;Get next mark
CAIE RET,MKEOC ;End of command?
CALL NOEOC ; Ooops.
REPEAT 0,<
CALL PLGET,PLST,<[P.TYPE]> ;Is there a type property?
CAIE RET,TYPE.T ;Is it text?
JUMPN RET,[ ;No, error if anything else is specified
CALL SNDMK2,<[MKNO]>,<[RCILTY]>,<[[ASCIZ/Only Type implemented is Text./]]>
RETURN ]
>;REPEAT 0
CALL PLSTNM,PLST,<[OUTBLK+1]> ;Construct a file name
CALL CHKPRO,PLST,<[OUTBLK+1]>,<[A.WRITE]>
JUMPN RET,[ ;Can we access this for reading?
PUSHP RET2 ;Save message
CALL SNDMRK,<[MKNO]>
XCT PUPWOP
EXCH RET,(P) ;Restore string, save code
CALL WRASCZ↑,RET,PUPWOP
POPP RET ;Get back code
CAIN RET,RCILUS ;Bad user name?
JRST[ CALL PLGET,PLST,<[P.UNAM]> ;Yes, print offender
CALL WRASCZ↑,RET,PUPWOP
JRST ISILUS ]
CALL WRIOSP↑,<[OUTBLK+1]>,PUPWOP
;All other message include filename
ISILUS: CALL SNDMRK,<[MKEOC]>
JRST DONE ] ;A rather hard failure. Too bad.
CALL CHKDEV,OUTBLK+1 ;Check legality of device
JUMPL RET,[MOVN RET,RET ;Bad device, convert to reply code
BADDEV: CALL SNDMRK,<[MKNO]> ;Illegal device
XCT PUPWOP
CALL WRASCZ,RET2,PUPWOP
CALL WRSIX,OUTBLK+1,PUPWOP
CALL SNDMRK,<[MKEOC]>
RETURN]
TLNN RET2,1 ;Is it an output device?
JRST[ MOVEI RET2,[ASCIZ/Device can't do output: /]
MOVEI RET,RCILDV
JRST BADDEV ]
MOVEM RET,OUTBLK ;Set type of OPEN
CALL OUTOPN ;Try opening the device first
JRST[ CALL SNDMRK,<[MKNO]>
MOVEI RET,RCILDV
XCT PUPWOP
CALL WRASCZ↑,<[[ASCIZ/Cannot open device: /]]>,PUPWOP
CALL WRSIX↑,OUTBLK+1,PUPWOP
CALL SNDMRK,<[MKEOC]>
JRST DONE ]
MOVE RET,OUTFIL+3 ;Save PPN for the moment
MOVEM RET,OUTFIL+4
printx We crash here if we reference a UDP that's write locked.
;;; This one is even worse, as at this point, not even WAITS knows the pack
;;; is write-locked!
ENTER OUTCHN,OUTFIL
JRST[ MOVEM RET,OUTFIL+3 ;Restore PPN
CALL SNDMRK,<[MKNO]>
MOVEI RET,RCFNF
XCT PUPWOP
CALL WRASCZ↑,<[[ASCIZ/Cannot write file: /]]>,PUPWOP
CALL WRIOSP↑,<[OUTBLK+1]>,PUPWOP
CALL SNDMRK,<[MKEOC]>
JRST DONE ]
MOVEM RET,OUTFIL+3 ;Put back the stupid PPN
SKIPN NEWFLG
JRST[ CALL SNDMK2,<[MKYES]>,<[0]>,<[[ASCIZ/Ready to accept file./]]>
JRST REMRK1 ]
CALL SNDMRK,<[MKPLST]> ;Send prefix
CALL PLGET,PLST,<[P.EOLC]> ;Is there a type property?
CAIN RET,ELTRNS
HRROI RET,SNDTRNS ;Send (EOL-Convention TRANSPARENT)
CAIN RET,ELCRLF
HRROI RET,SNDCRLF ;Send (EOL-Convention CRLF)
CAIN RET,ELCR
HRROI RET,SNDCR ;Send (EOL-Convention CR)
TLZN RET,-1 ;Did we find an something
SETZ RET, ; No, don't supply property then.
CALL SNDLPL,<[OUTBLK+1]>,RET ;Send propery list for their approval
CALL SNDMRK,<[MKEOC]>
SKIPN SDEBUG ;Debugging?
JRST REMRK1 ; No, be quiet
CALL WRASCZ↑,RET,ERMSOP
CALL WRIOSP,<[OUTBLK+1]>,ERMSOP
CALL WRASCZ↑,<[[ASCIZ/
/]]>,ERMSOP
REMRK1: CALL GETMRK ;Wait for response
CAIN RET,MKNO ;Skip it?
JRST[ RELEASE OUTCHN,3 ;Abort request
CALL PUPGET ;Yes, ignore reply code
CALL UNEXMK ; Unexpected mark or EOF
CALL SRVLMS,<[[ASCIZ/File skipped: /]]>
CALL GETMRK
CAIE RET,MKEOC
CALL NOEOC
CALL SNDMK2,<[MKNO]>,<[RCNOST]>,<[
[ASCIZ/File skipped at request of user./]]>
JRST DONE ]
CAIN RET,MKCOMM ;Remark?
JRST[ CALL SRVLMS,<[[ASCIZ/Comment: /]]>
JRST REMRK1]
CAIE RET,MKFILE ;It better be a YES if it's not a NO
JRST[ RELEASE OUTCHN,3 ;Abort request
CALL CNTXER
JRST DONE ]
SKIPE SDEBUG
JRST[ CALL WRASCZ↑,<[[ASCIZ/Recieving file...
/]]>,ERMSOP
JRST .+1]
CALL PLGET,PLST,<[P.EOLC]> ;Get end of line convention
SETOM RET2 ;Assume CR
CAIE RET,ELCRLF ;CRLF
CAIN RET,ELTRNS ; or Transparent?
SETZM RET2 ; Yes, don't convert
PUSHP RET2 ;Save CR flag
CALL PLGET,PLST,<[P.TYPE]> ;Get type of transfer
JUMPE RET,[ ;None specified, indicate default
CALL SNDMRK,<[MKCOMM]>
CALL WRASCZ,<[[ASCIZ/Assuming Type Text/]]>,PUPWOP
MOVEI RET,TYPE.T ;Invent code for it
JRST .+1]
LSH RET,9 ;Shift into position for DOSND
PUSHP RET ;Save on stack while getting bytesize
CALL PLGET,PLST,<[P.BYTE]> ;Get bytesize for transfer
IOR RET,(P) ;Include type code
POPP <(P)> ;Flush type code from stack
POPP RET2 ;Get back CR flag
CALL DORCV,RET2,RET ;Do actual transfer, by specified type
PUSHP RET ;Save error code on the stack
JUMPE RET,FINLP
IFLUSH: CALL PUPGET ;Flush input buffer
SKIPA
JRST IFLUSH
; \ /
;Caution: RET2 (textual confirmation) must be preserved for WRASCZ
FINLP: CALL GETMRK ;Get results from transfer
CAIN RET,MKNO ;Abort?
JRST[ RELEASE OUTCHN,3 ;Flush file
CALL SRVLMS,<[[ASCIZ/Store aborted: /]]>
CALL SNDMK2,<[MKNO]>,<[RCNOST]>,<[
[ASCIZ/Store aborted due to abnormal completion./]]>
CALL GETMRK ;Consume the EOC
CAIE RET,MKEOC
CALL NOEOC
JRST DONEX ]
CAIN RET,MKCOMM ;Comment?
JRST[ CALL SRVLMS,<[[ASCIZ/Comment: /]]>
JRST FINLP ]
CAIE RET,MKYES ;Yes? (It better be!)
JRST[ CALL CNTXER ;Ooops
RELEASE OUTCHN,3 ;Don't keep file!
JRST DONEX ]
SKIPE (P) ;Check error code
JRST[ CALL SRVLMS,<[[ASCIZ/Store finished with local device error: /]]>
RELEASE OUTCHN,3 ;Don't keep file!
CALL SNDMK2,<[MKNO]>,<-1(P)>,RET2
CALL GETMRK ;Consume the EOC
CAIE RET,MKEOC
CALL NOEOC
JRST DONEX ]
CALL SRVLMS,<[[ASCIZ/Store complete: /]]>
CLOSE OUTCHN, ;Finish writing file
RELEASE OUTCHN,
CALL SNDMRK,<[MKYES]> ;Indicate success
MOVEI RET,0
XCT PUPWOP
CALL WRASCZ↑,RET2,PUPWOP
CALL WRASCZ↑,<[[ASCIZ/Store of /]]>,PUPWOP
CALL WRIOSP↑,<[OUTBLK+1]>,PUPWOP
CALL SNDMRK,<[MKEOC]>
CALL GETMRK ;Consume the EOC
CAIE RET,MKEOC
CALL NOEOC
DONEX: POPP RET ;Flush error code
; \ /
DONE: CALL RLPLST,PLST ;Recover space from property list
RETURN
SUBREND SRNSTO
SUBR SRDIR ;Server Directory
;------------------------------------------------------------------------------
;
; Directory - List what file are in local file system
;
;------------------------------------------------------------------------------
LOCALS{PLST,SRCLST}
ACCUMULATOR{T1,T2,CNT} ;T1,T2 clobbered by ACCCHK
PUSHP T1
PUSHP T2
PUSHP CNT ;Save accumulator, local must be in AC
SETZM CNT ;No files so far.
CALL RDPLST,PUPROP ;Read property list
JUMPE RET,[TLNN RET2,-1 ;Is there an error message?
HRLI RET2,[ASCIZ/Empty property list./] ;No, make one
HLRZ RET,RET2
PUSHJ P,WARNMSG
ERRARG TXT,TXFHSN
ERRARG TXT,<@RET>
ERRARG TXT,[ASCIZ/ Terminator = /]
ERRARG CHR,RET2
ERRARG CRLF,0
0
CALL SNDMK2,<[MKNO]>,<[RCMFPL]>,RET
CALL GETMRK ;Get next mark
CAIE RET,MKEOC ;End of command?
CALL NOEOC ; Ooops.
RETURN] ;OK to just return, AC's not clobbered yet.
MOVEM RET,PLST
CALL GETMRK ;Get next mark
CAIE RET,MKEOC ;End of command?
CALL NOEOC ; Ooops.
CALL PLSTSL,PLST ;Get search list from property list
JUMPE RET,[CALL SNDMK2,<[MKNO]>,<[RCILSF]>,<[
[ASCIZ/No match possible, probably filename too long./]]>
CALL SNDMRK,<[MKCOMM]>
;;; MOVEI RET,0
;;; XCT PUPWOP
CALL WRASCZ↑,<[[ASCIZ/Expecting XXXXXXX.YYY[PRG,PRJ]/]]>,PUPWOP
JRST DONE]
JUMPL RET,[
MOVN RET,RET ;Error, convert to reply code
CALL SNDMRK,<[MKNO]> ;Construct complaint.
XCT PUPWOP
CALL WRASCZ↑,RET2,PUPWOP
CALL SNDMRK,<[MKEOC]>
JRST DONE ]
MOVEM RET,SRCLST ;Save search list
MOVEM RET2,MFDBLK+1 ;Set device name
MOVEM RET2,UFDBLK+1
MOVEM RET2,FAKDEV ;For SNDLPL to print device.
CALL CHKDEV,UFDBLK+1 ;Check legality of device
JUMPL RET,[MOVN RET,RET ;Bad device, convert to reply code
BADDEV: CALL SNDMRK,<[MKNO]> ;Illegal device
XCT PUPWOP
CALL WRASCZ,RET2,PUPWOP
CALL WRSIX,UFDBLK+1,PUPWOP
CALL SNDMRK,<[MKEOC]>
JRST DONE]
TLNN RET2,4 ;Is it a directory device?
JRST[ MOVEI RET2,[ASCIZ/Device does not have directories: /]
MOVEI RET,RCILDV
JRST BADDEV ]
EXCH RET,MFDBLK ;Temp. set status for our device
CALL MFDOPN ;Open device
JRST[ MOVEM RET,MFDBLK ;Restore normal status
CALL SNDMRK,<[MKNO]>
MOVEI RET,RCILDV
XCT PUPWOP
CALL WRASCZ↑,<[[ASCIZ/Cannot open device: /]]>,PUPWOP
CALL WRSIX↑,INBLK+1,PUPWOP
CALL SNDMRK,<[MKEOC]>
JRST DONE ]
MOVEM RET,MFDBLK ;Restore normal status
CALL UFDOPN ;Do OPEN a second time
PUSHJ P,DRYROT ; This can't happen for any normal device.
MOVE RET,MFDFIL ;MFD has strange property of filename=ppn
MOVEM RET,MFDFIL+3
LOOKUP MFDCHN,MFDFIL
JRST[ CALL SNDMRK,<[MKNO]>
MOVEI RET,RCILDV
XCT PUPWOP
CALL WRASCZ↑,<[[ASCIZ/Not a directory device: /]]>,PUPWOP
CALL WRSIX↑,INBLK+1,PUPWOP
CALL SNDMRK,<[MKEOC]>
JRST DONE ]
MOVE RET,SRCLST ;Make special case check for single PPN
SETCM RET2,SNOFFS(RET) ;Look at file name only
CAMN RET2,SNONS(RET)
JRST[ MOVEM RET2,UFDBUF ;Set name of UFD
HLRZ RET2,SNNEXT(RET) ;Get list of files under it
JUMPE RET2,DIRTRM ;"Can't happen"
HRRZ RET,(RET) ;Is there more than one UFD on this list?
JUMPN RET,.+1 ; Yes, probably must search MFD (sigh...)
CALL CHKPRO,PLST,<[MFDBLK+1]>,<[A.STAT]>
;Check protection to get side effect of verifying
;user name. GOTUFD will do the rest.
CALL GOTUFD,SRCLST ;Search this UFD
JRST DIRTRM ]
CALL MAPSL,SRCLST,<[PUSHJ P,MFDWRD]>,<[GOTUFD]>
;For each matching directory...
DIRTRM: JUMPE CNT,[CALL SNDMK2,<[MKNO]>,<[RCFNF]>,<[[ASCIZ/No such file(s)./]]>
JRST DONE]
CALL SNDMRK,<[MKEOC]> ;Terminate list of files.
; \ /
DONE: CALL RLPLST,PLST ;Recover space from property list
SKIPN SRCLST ;Recover space from search list
JRST FINIS
CALL RLSL,SRCLST ;Recover space from search list
RELEASE MFDCHN, ;Don't need to reference these anymore
RELEASE UFDCHN, ;Don't need to reference these anymore
FINIS: POPP CNT
POPP T2
POPP T1
RETURN
;Found a UFD, search it (one argument on the stack)
;(CAUTION: You can't make symbolic stack references here.)
GOTUFD: MOVE RET,UFDBUF ;Copy parameters for LOOKUP
MOVEM RET,UFDFIL
MOVE RET,MFDFIL ;Reset PPN for all needing
MOVEM RET,UFDFIL+3
HLRZ RET,@-1(P) ;Get sublist
JUMPE RET,[pushj p,dryrot ;No files: "Can't happen"
JRST GOTUF9] ;None, ignore this
LOOKUP UFDCHN,UFDFIL ;Open the UFD
JRST[ MOVEI TAC,[ASCIZ/Directory not found: /]
ILUFDR: CALL SNDMRK,<[MKCOMM]> ;Put out a comment for LOOKUP failure
;;; MOVEI RET,0
;;; XCT PUPWOP
CALL WRASCZ↑,TAC,PUPWOP ;Send out remark indicating lossage.
HLRZ RET,UFDFIL
CALL WRSIX,RET,PUPQCK
MOVEI RET,","
XCT PUPWOP
HRRZ RET,UFDFIL
CALL WRSIX,RET,PUPQCK
JRST GOTUF9 ]
IOPUSH UFDCHN,0 ;Move into channel used to do protection checking
PUSHJ P,DRYROT ; "Can't happen"
IOPOP PROCHN,0
PUSHJ P,DRYROT ; "Can't happen"
MOVE RET2,UFDFIL ;PPN of directory to check
MOVEI TAC,A.READ ;Can we read the UFD?
PUSHJ P,GRPCHK ;Decide if we have owner access to UFD
IOPUSH PROCHN,0 ;Move back into normal place
PUSHJ P,DRYROT ; "Can't happen"
IOPOP UFDCHN,0
PUSHJ P,DRYROT ; "Can't happen"
MOVE RET,UFDFIL+2 ;Setup protection
PUSHJ P,ACCCHK ;Check for access at all
JRST[ MOVEI TAC,[ASCIZ/Directory protected: /]
JRST ILUFDR ]
HLRZ RET,@-1(P) ;Get sublist again.
CALL MAPSL,RET,<[PUSHJ P,UFDWRD]>,<[GOTFIL]>
;For each matching file in directory...
GOTUF9: POP P,-1(P) ;Flush one argument and return.
POPJ P,
;Got a file. Print information about it. (CAUTION: You can't make symbolic
;stack references here.)
GOTFIL: MOVN RET,UFDBUF+4 ;Make it look like a LOOKUP block
MOVSM RET,UFDBUF+3 ;See, it's a negative swapped word count!
MOVE RET,UFDFIL
MOVEM RET,UFDBUF+4 ;Fake a PPN
CALL SNDMRK,<[MKPLST]> ;Send prefix
CALL SNDLPL,<[UFDBUF-INFILE+INBLK+1]>,<[0]>
;Send property list for file
ADDI CNT,1 ;Count files.
POP P,-1(P) ;Flush one argument and return
POPJ P,
SUBREND SRDIR
SUBR SRSMAI ;Server Send Mail
;------------------------------------------------------------------------------
;
; Send Mail
;
;------------------------------------------------------------------------------
LOCALS{NAMLST,LSTLST,CURNAM}
LOCALS{EOLFLG,SNDR}
SETOM EOLFLG ;Assume CR
MOVEI TAC2,1 ;Number of mailboxes
CALL RDPLST,PUPROP ;Read property list
JUMPE RET,[TLNN RET2,-1 ;Is there an error message?
HRLI RET2,[ASCIZ/Empty property list./] ;No, make one
HLRZ RET,RET2
PUSHJ P,WARNMSG
ERRARG TXT,TXFHSN
ERRARG TXT,<@RET>
ERRARG TXT,[ASCIZ/ Terminator = /]
ERRARG CHR,RET2
ERRARG CRLF,0
0
CALL SNDMK2,<[MKNO]>,<[RCMFPL]>,<[[ASCIZ/Bad property list./]]>
CALL GETMRK ;Get next mark
CAIE RET,MKEOC ;End of command?
CALL NOEOC ; Ooops.
RETURN] ;OK to just return, AC's not clobbered yet.
SKIPN SDEBUG
JRST PLSTL2
PUSHP RET
CALL WRASCZ↑,<[[ASCIZ/Mail from: /]]>,ERMSOP
CALL PLGET,<(P)>,<[P.SNDR]> ;Too bad we have to do this twice
SKIPN RET
MOVEI RET,[ASCIZ/[No Sender property!]/]
CALL WRASCZ↑,RET,ERMSOP
CALL WRASCZ↑,<[[ASCIZ/
/]]>,ERMSOP
POPP RET
CAIA
PLSTLP: ADDI TAC2,1 ;Count another mailbox
PLSTL2: MOVE RET2,LSTLST ;Add to list of property lists
CALL PFCONS ;(Don't you dare interpret them until they're
MOVEM RET,LSTLST ; all read, otherwise, deadlock could result)
HLRZ RET,(RET) ;Get back property list
CALL PLGET,RET,<[P.EOLC]> ;Get end of line convention
CAIE RET,ELCRLF ;CRLF
CAIN RET,ELTRNS ; or Transparent?
SETZM EOLFLG ; Yes, don't convert
HLRZ RET,@LSTLST ;Get pointer to property list again
CALL PLGET,RET,<[P.SNDR]> ;Too bad we have to do this twice
SKIPE RET
MOVEM RET,SNDR ;Remember the sender
CALL RDPLST,PUPROP
JUMPN RET,PLSTLP
CALL GETMRK ;Get next mark
CAIE RET,MKEOC ;End of command?
CALL NOEOC ; Ooops.
MOVE TAC,LSTLST ;Get list of names
NAMELP: HLRZ RET,(TAC) ;Get value part of node
CALL PLGET,RET,<[P.MLBX]> ;Get mailbox
JUMPE RET,[MOVNI RET,RCILMB
MOVEI RET2,[ASCIZ/No mailbox given!/]
JRST MLBXER]
MOVEM RET,CURNAM ;Save pointer to name
SKIPN SDEBUG
JRST NONDEB
CALL WRASCZ↑,<[[ASCIZ/To: /]]>,ERMSOP
CALL WRASCZ↑,CURNAM,ERMSOP
CALL WRASCZ↑,<[[ASCIZ/
/]]>,ERMSOP
NONDEB:
CALL FNDUSR,CURNAM ;Get a name from it
JUMPL RET,[
MLBXER: CALL SNDMRK,<[MKMBEX]> ;Complain
MOVN RET,RET ;Error code
XCT PUPWOP ;Send error code
;;Apparently this number is supposed to be sent as text.
;; MOVE RET,TAC2 ;Send prop. list number
;; XCT PUPWOP
CALL WRINT↑,TAC2,<[=10]>,PUPWOP ;Send it in decimal text
MOVEI RET," " ;Terminate decimal number with a space
XCT PUPWOP
CALL WRASCZ↑,RET2,PUPWOP ;Send textual reason
CALL WRASCZ↑,CURNAM,PUPWOP ;Send thing we were checking for.
JRST NOUSER ]
MOVE RET2,NAMLST ;Add to list of names
CALL PFCONS
MOVEM RET,NAMLST
NOUSER: HRRZ TAC,(TAC) ;Get next entry from list
SUBI TAC2,1 ;Number of mailbox we're working on.
JUMPN TAC,NAMELP ;Repeat for each entry in list
SKIPN TAC,NAMLST ;Get list of names
JRST[ CALL SNDMK2,<[MKNO]>,<[RCNOMB]>,<[[ASCIZ/No valid mailbox(es)/]]>
JRST FINIS ]
;We're going to write DSK:<unique name>.FTP[RMD,SYS]
MOVE RET,[XWD [ 200 ;Don't stop job on errors
SIXBIT/DSK/
0 ;Buffer pointer is saved during BLT
0 ;File name gets filled in
SIXBIT/FTP/
0
SIXBIT/RMDSYS/
],OUTBLK]
PUSHP OUTBLK+2 ;Save buffer header during BLT
BLT RET,OUTFILE+3 ;Set output file
POPP OUTBLK+2
ACCTIM RET, ;HIGHLY MNEMONIC FILE NAME
DPB RET,[POINT 12,RET,29] ;SHIFT RH BY 6 BITS
MOVEM RET,OUTFIL
PJOB RET,
DPB RET,[POINT 6,OUTFIL,35]
CALL OUTOPN ;Get ready to write onto DSK
PUSHJ P,DRYROT ; Can't INIT DSK!!!
MOVEI TAC,=10 ;Number of times to try before giving up
RELOOK: LOOKUP OUTCHN,OUTFIL ;Make sure file doesn't already exist
JRST[ HRRZ RET,OUTFIL+1 ;Get reason for failure
JUMPE RET,TRYENT ;If file doesn't exist, take it
JRST .+1 ] ;Some other reason, try another
DATE RET, ;Ooops, collision. Try offseting by
MOVS RET, ;something different, in case the remind
ADDM RET,OUTFIL ;phantom is really gronked
MOVE RET,[SIXBIT/RMDSYS/]
MOVEM RET,OUTFIL+3 ;Restore PPN
SOJG TAC,RELOOK ;Retry a few times
DSKLOS: RELEAS OUTCHN,
PUSHJ P,WARNMSG ;Boy, are we losing!
ERRARG TXT,[ASCIZ/Can't write DSK:xxxxxx.FTP[RMD,SYS]!!!/]
ERRARG CRLF,0
0
CALL SNDMK2,<[MKNO]>,<[RCTFSF]>,<[
[ASCIZ/Can't send any mail right now, try later./]]>
JRST FINIS
; ---
TRYENT: ENTER OUTCHN,OUTFIL ;Now, try to write the file.
JRST[ HRRZ RET,OUTFIL ;Failed. Get reason
CAIE RET,12 ;Disk full?
JRST DSKLOS ; No, something is wrong!
RELEASE OUTCHN,3
CALL SNDMK2,<[MKNO]>,<[RCFULL]>,<[
[ASCIZ/Disk is full! Try later./]]>
JRST FINIS ]
MOVEI RET,[ASCIZ?MAIL/FROM "?] ;Takes no more space than single use
CALL WRASCZ↑,RET,OUTOP ;and doesn't leave FAIL confused.
HLRZ RET,@LSTLST ;Get first property list
CALL PLGET,RET,<[P.SNDR]>
SKIPN RET ;If sender is given once, that's enough
MOVE RET,SNDR
JUMPE RET,[RELEAS OUTCHN,3 ;Flush that message, hard!
CALL SNDMK2,<[MKNO]>,<[RCILSN]>,<[[ASCIZ/Sender not given./]]>
JRST FINIS]
CALL WRASCZ↑,RET,OUTCKQ ;Copy name, checking for quotes
movei ret,[asciz?" ?] ;must end the quoted /FROM string!
call wrascz↑,ret,outop
MOVE TAC,NAMLST
TOLOOP: HLRZ RET,(TAC) ;Get name
TLO RET,(<POINT 7,0>)
PUSHP RET
PUSHP TAC
SETZ TAC,
; \ /
;Unlike the TOPS-20 mailer, SAIL's mailer requires next destination to be quoted
;when it isn't local. Here, we search for the last "@", and quote everything
;up to that. We assume the rest is a valid host name. TVR/May86
TOLP2: ILDB RET,-1(P) ;Get character from destination
CAIE RET,"@" ;Does it look like a host name?
CAIN RET,"%"
MOVE TAC,-1(P) ; Yes, remember the last thing like this we've seen
JUMPN RET,TOLP2 ;Repeat until end of string
MOVEM TAC,-1(P) ;Remember the division
POPP TAC ;Get back list poitner
HLRZ RET,(TAC) ;So we can get back to beginning of list
SKIPN (P) ;Is there a host name?
JRST[ POP P,(P) ; No, we're done then.
JRST NOHOST ]
LDB RET,(P) ;Save host separator
PUSHP RET
SETZ RET, ;Terminate string at last "@"
DPB RET,-1(P)
MOVEI RET,42 ;Double-quote
XCT OUTOP
HLRZ RET,(TAC) ;Get back name again
CALL WRASCZ↑,RET,OUTOP ;Output from beginning of string up to last "@"
MOVEI RET,42 ;Double-quote
XCT OUTOP
POPP RET ;Put back host separator. We could force an "@"
DPB RET,(P) ; here, but for debugging purposes it seemed
; better to leave it as it was, at least for now.
POPP RET ;Get rest of destination string.
ADD RET,[7B5] ;Backup string over "@" (or maybe "%")
; \ /
NOHOST: CALL WRASCZ↑,RET,OUTOP ;Output unquoted destination or @<host name>
HRRZ TAC,(TAC) ;Get next name
JUMPN TAC,[MOVEI RET,"," ;Separate by commas
XCT OUTOP
JRST TOLOOP]
CALL WRASCZ,<[[BYTE (7) 15,12,14,"R","e"↔
ASCIZ/ceived: from /]]>,OUTOP
;Rest is message
;insert line saying when Received and from where, e.g.:
;Received: from CMU-CS-C by SU-AI with NCP/FTP; 20 Jan 83 11:42:41 PST
CALL WRASCZ↑,<[HNAME]>,OUTOP ;ptr to host name
CALL WRASCZ↑,<[[ASCIZ/ by /]]>,OUTOP
CALL WRASCZ↑,<[WAITSH]>,OUTOP
CALL WRASCZ↑,<[[ASCIZ $ with PUP; $]]>,OUTOP
ACCTIM RET, ;get current date,,time in secs
CALL WRDAYT↑,RET,OUTOP
DAYLIT←←261 ;LOWCORE POINTER TO NONZERO IF DAYLIGHT SAVINGS TIME
MOVEI RET,DAYLIT ;FIND OUT IF DAYLIGHT SAVINGS
PEEK RET, ;get ptr to cell
PEEK RET, ;get flag from cell
SKIPN RET ;skip if daylight savings
SKIPN RET,[[ASCIZ/ PST
/]]
MOVEI RET,[ASCIZ/ PDT
/]
CALL WRASCZ↑,RET,OUTOP ;Output time
CALL SNDMK2,<[MKYES]>,<[0]>,<[[ASCIZ/OK, ready for message./]]>
REMRK1: CALL GETMRK ;See what we get in response
CAIN RET,MKCOMM ; Remark?
JRST[ CALL SRVLMS,<[[ASCIZ/Comment: /]]> ;Yes, print it
JRST REMRK1]
CAIN RET,MKNO ;Changed their mind at the last moment?
JRST[ RELEASE OUTCHN,3 ;First, flush message, hard!
CALL PUPGET ;Yes, flush error code
CALL UNEXMK ; Unexpected mark or EOF
CALL SRVLMS,<[[ASCIZ/Mail aborted: /]]>
CALL GETMRK
CAIE RET,MKEOC ;Make sure it's properly terminated
CALL NOEOC
JRST FINIS ]
CAIE RET,MKFILE ;Anything else is in error
JRST[ RELEASE OUTCHN,3 ;Before anything else, blast message
CALL CNTXER
JRST FINIS ]
CALL DORCV,EOLFLG,<[0]> ;Copy message to disk
MOVE TAC,RET
REMRK2: CALL GETMRK ;Get indication from user about transfer
CAIN RET,MKCOMM
JRST[ CALL SRVLMS,<[[ASCIZ/Comment: /]]>
JRST REMRK2 ]
CAIN RET,MKNO ;The protocol doesn't specify this, but it's
;obvious.
JRST[ RELEASE OUTCHN,3 ;First, flush losing message, hard!
CALL PUPGET ;Yes, ignore reply code
CALL UNEXMK ; Unexpected mark or EOF
CALL SRVLMS,<[[ASCIZ/Mail aborted: /]]>
CALL GETMRK ;Make sure there is an EOC
CAIN RET,MKEOC
CALL NOEOC
JRST FINIS ]
CAIE RET,MKYES ;If not YES, then error
JRST[ RELEASE OUTCHN,3 ;Before anything else, blast message
CALL CNTXER
JRST FINIS ]
CALL SRVLMS,<[[ASCIZ/Mail complete: /]]>
CALL GETMRK ;Make sure we're terminated with an EOC.
CAIE RET,MKEOC
CALL NOEOC
JUMPN TAC,[ ;Any errors from our side?
RELEASE OUTCHN,3 ;Yeah, we blew it.
CALL SNDMK2,<[MKNO]>,<[RCTFSF]>,<[
[ASCIZ/Mail failed, probably disk full./]]>
JRST FINIS ]
CALL SNDMK2,<[MKYES]>,<[0]>,<[[ASCIZ/Mail transfer completed and queued for delivery./]]>
CLOSE OUTCHN, ;Finished.
RELEAS OUTCHN,
MOVEI TAC,['<RMND>'↔'RMDSYS'↔0]
WAKEME TAC, ;Wake up remind phantom to process mail
JFCL ;can't fail unless phantom name changes
; \ /
FINIS: SKIPE TAC,NAMLST ;Are there any mailbox names to release?
JRST[
FINIS2: HLRZ RET,(TAC) ;Yes, flush one
CALL FSREL,RET ;Release the name
MOVE RET,TAC ;Save this node
HRRZ TAC,(TAC) ;Get at next node
CALL PFUNCS ;Release the LISPish node
JUMPN TAC,FINIS2 ;Repeat for each entry
JRST .+1 ]
SKIPE TAC,LSTLST ;Are there any property lists?
JRST[
FINIS3: HLRZ RET,(TAC) ;Yes, flush one
CALL RLPLST,RET ;Release the property list
MOVE RET,TAC ;Save this node
HRRZ TAC,(TAC) ;Get at next node
CALL PFUNCS ;Release the LISPish node
JUMPN TAC,FINIS3 ;Repeat for each entry
JRST .+1 ]
RETURN
OUTCKQ: PUSHJ P,[CAIN RET,'"'-' '+" " ;Copy name, doubling "'s
PUSHJ P,PUTBYT
JRST PUTBYT]
OUTOP: PUSHJ P,PUTBYT ;Thing to use to write mail on disk
SUBREND SRSMAI
SUBR SRVLMS,PREAMB ;Log/flush message in server mode
COMMENT ⊗ ---------------------------------------------------------------------
Calling Sequence:
PUSH P,[<address of string>]
PUSHJ P,SRVLMS
Returns:
Undefined
Description:
Logs human readable messages if server debugging is enabled. Otherwise,
simply flushes them.
Calls:
WRASCZ,PIPEIT
Side effects:
Clobbers RET
Flushes PUP stream to next mark.
⊗;------------------------------------------------------------------------------
SKIPN SDEBUG ;Logging messages today?
JRST NOMSG ; No, just flush 'em
CALL WRASCZ↑,PREAMB,ERMSOP
CALL PIPEIT,PUPROP,ERMSOP
;Copy from input stream to output stream
CALL WRASCZ↑,<[[ASCIZ/
/]]>,ERMSOP ;Make sure line gets terminated
RETURN
;Not logging messages, flush human readable string
NOMSG: XCT PUPROP ;Flush out stream
JUMPN RET,NOMSG
RETURN
SUBREND SRVLMS
SUBR USRETR ;RETR command (also USDELE, EOLHAK)
;------------------------------------------------------------------------------
;
; RETRIEVE
;
;------------------------------------------------------------------------------
TDZA RET,RET ;Normal form
↑USDELE: SETO RET,
LOCALS{PLST,NOTWILD,FILCNT}
LOCALS{NTAKEN,ASKFLAG,DELFLAG}
MOVEM RET,DELFLAG ;Set flag meaning this is a deletion.
CALL RDSTRB,<[FILBRK]>,CMDOP ;Look for a file name
SKIPE DELFLAG ;Delete form?
JRST[ CALL CMDTRM ;Command terminated properly?
JRST NAMEOK ; Yes, take it!
PUSHJ P,WARNMSG
ERRARG TXT,[ASCIZ/Illegal character for DELETE: /]
ERRARG CHR,RET2
ERRARG CRLF,0
ERRARG TXT,[ASCIZ/Form is: DELE serverfile/]
ERRARG CRLF,0
0
RETURN ]
CAIN RET2,"→" ;Check for wrong arrow
JRST[
CNFUSD: PUSHJ P,WARNMSG
ERRARG TXT,[ASCIZ/Form is: RETR localfile←serverfile/]
ERRARG CRLF,0
0
RETURN ]
CAIE RET2,"←" ;WAITS file name present?
CAIN RET2,"="
JRST[ PUSHP <[POINT 7,NAMBUF]> ;Yes.
MOVEI RET,(P) ;Make a stream pointer to NAMBUF
HRLI RET,(<ILDB RET,>)
CALL RDIOSP,<[OUTBLK+1]>,RET,<[0]> ;Try to parse local file
JRST[ PUSHJ P,WARNMSG
ERRARG TXT,[ASCIZ/Couldn't parse local file name./]
ERRARG CRLF,0
0
RETURN ]
POPP <(P)> ;Flush stream pointer from stack.
CALL RDSTRB,<[LINBRK]>,CMDOP ;Now, read server filename
SETOM NOTWILD ;Output is not a wild card.
JRST .+1]
CALL CMDTRM ;Command terminated normally?
SKIPA
JUMPN RET,NAMEOK ; Yes, assuming there was something there
PUSHJ P,WARNMSG
ERRARG TXT,[ASCIZ/Illegal terminator: /]
ERRARG CHR,RET2
ERRARG CRLF,0
0
RETURN
; ---
NAMEOK: MOVE RET,NOTWILD ;Always ask on wild card transfers for
SETCAM RET,ASKFLAG ;now at least.
SKIPN DELFLAG ;DELETE form?
SKIPA RET,[MKRETR] ; No, must be RETRIEVE
MOVEI RET,MKDELE ; Yes, different mark code.
CALL SNDMRK,RET ;Request list of files for approval
PUSHP <[POINT 7,NAMBUF]>
MOVEI RET,(P)
HRLI RET,(<ILDB RET,>)
CALL SNDUPL,RET,<[SNDUNM]> ;Send property list from user's input
POPP <(P)> ;Flush stream pointer for stack.
CALL SNDMRK,<[MKEOC]> ;Terminate request
; \ /
L1: CALL GETMRK ;Wait for response
CAIN RET,MKCOMM ;Comment?
JRST[ CALL USRLMS,<[TXSPRE]> ;Yes, print it
JRST L1 ] ;and back for more
CAIN RET,MKNO ;Complaint?
JRST[ CALL PUPGET ;Yes, ignore number
CALL UNEXMK ; Unexpected mark or EOF
CALL USRLMS,<[TXSPRE]>
CALL SUSPND ;No files stop things
CALL GETMRK ;Get termination
CAIE RET,MKEOC
CALL NOEOC
RETURN ]
SKIPA
L2: CALL GETMRK
CAIN RET,MKCOMM ;Comment (twice, sigh..)
JRST[ CALL USRLMS,<[TXSPRE]> ;Yes, print it
JRST L2 ] ;and back for more
CAIN RET,MKEOC ;End of list?
JRST[ SKIPE FILCNT ;Any files seen?
RETURN
CALL WRASCZ↑,<[[ASCIZ/(Server sent empty list in response to RETRIEVE or DELETE.)
/]]>,ERMSOP
CALL SUSPND ;This is wierd enough to stop things
RETURN ]
CAIE RET,MKPLST ;A file?
JRST[ CALL CNTXER ; No, a mistrake
RETURN ]
CALL RDPLST,PUPROP ;Read property list
JUMPE RET,[TLNN RET2,-1 ;Is there an error message?
HRLI RET2,[ASCIZ/Empty property list./] ;No, make one
HLRZ RET,RET2
PUSHJ P,WARNMSG
ERRARG TXT,TXFHSN
ERRARG TXT,<@RET>
ERRARG TXT,[ASCIZ/ Terminator = /]
ERRARG CHR,RET2
ERRARG CRLF,0
0
AOS FILCNT ;Count them, no matter how bad they are.
JRST L2] ;Keep going...
MOVEM RET,PLST ;Save pointer to property list
L3: CALL GETMRK ;Get termination
CAIN RET,MKCOMM ;Silly response?
JRST[ CALL USRLMS,<[TXSPRE]> ;Yes, print it
JRST L2 ] ;and back for more
CAIE RET,MKEOC ;Better be End-of-command.
CALL NOEOC ;Standard, losing thing.
SKIPE NTAKEN ;Any taken yet?
SKIPN NOTWILD ;and are we taking only one?
SKIPA ; No, don't reject this out of hand
JRST SKPFIL ; Yes, flush the rest
CALL PLGET,PLST,<[P.SFIL]> ;Get name of file
JUMPE RET,[CALL PLGET,<[P.NAMB]>
JUMPN RET,.+1
PUSHJ P,WARNMSG
ERRARG TXT,[ASCIZ/Recieved property list with no filename property!/]
ERRARG CRLF,0
0
JRST SKPFIL]
CALL WRASCZ↑,RET,ERMSOP ;Print file name
CALL PLGET,PLST,<[P.SIZE]> ;Get size of file
JUMPE RET,SKPSIZ
PUSHP RET
MOVEI RET,"("
XCT ERMSOP
POPP RET
CALL WRASCZ↑,RET,ERMSOP ;Print size in bytes (it really is
;a string!)
CALL WRASCZ↑,<[[ASCIZ/ bytes)/]]>,ERMSOP ;Print size in bytes
SKPSIZ: SKIPE DELFLAG ;Delete form?
JRST[ SKIPN ASKFLAG ;Yes, are we asking?
JRST TAKEIT ; No, just delete it
CALL WRASCZ,<[[ASCIZ/ (Confirm)/]]>,ERMSOP
JRST PLSASK ] ;Please ask user.
CALL WRASCZ↑,<[[ASCIZ/ to /]]>,ERMSOP ;Message
SKIPN NOTWILD ;Have we specified a file name?
JRST[ CALL PLGET,PLST,<[P.NAMB]> ;No, get it from server.
JUMPE RET,[CALL QMKRET ;Print ?<return>
PUSHJ P,WARNMSG
ERRARG TXT,[ASCIZ/Server didn't send Name-Body. /]
ERRARG TXT,[ASCIZ/You will have to specify an output file. /]
ERRARG CRLF,0
ERRARG TXT,[ASCIZ/Aborting retrieve./]
0
SKREST: SETOM NOTWILD ;Force rest to be skipped.
SETOM NTAKEN
JRST SKPFIL ]
HRLI RET,(<POINT 7,0>) ;Make string pointer
PUSHP RET
MOVEI RET,(P)
HRLI RET,(<ILDB RET,>)
CALL RDIOSP,<[OUTBLK+1]>,RET,<[0]>
JRST[ POP P,(P) ;Don't use POPP in literal
CALL QMKRET
PUSHJ P,WARNMSG
ERRARG TXT,[ASCIZ/Server's Name-Body isn't a legal WAITS filename./]
ERRARG CRLF,0
ERRARG TXT,[ASCIZ/You will have to specify an output file. /]
ERRARG CRLF,0
ERRARG TXT,[ASCIZ/Aborting retrieve./]
0
JRST SKREST]
POPP <(P)>
JRST .+1]
CALL WRIOSP,<[OUTBLK+1]>,ERMSOP
SETZM OUTBLK ;Set type of open
CALL OUTOPN ;Try accessing device
JRST[ PUSHJ P,WARNMSG
ERRARG TXT,[ASCIZ/Can't OPEN device /]
ERRARG SIX,OUTBLK+1
ERRARG CRLF,0
0
JRST FLUSH ]
MOVE RET,OUTFIL+3
LOOKUP OUTCHN,OUTFIL ;Safety lookup
JRST[ HRRZ RET,OUTFIL+1 ;Get error code
JUMPN RET,[CALL QMKRET
PUSHJ P,WARNMSG
ERRARG TXT,[ASCIZ/Local file busy, protected, or illegal/.]
ERRARG CRLF,0
0
JRST SKPFIL ]
CALL WRASCZ↑,<[[ASCIZ/(New file)/]]>,ERMSOP
SKIPN ASKFLAG ;Should we ask?
JRST TAKEIT ; No, just do it.
JRST PLSASK ] ;Maybe ask for file name
MOVEM RET,OUTFIL+3 ;Restore PPN from LOOKUP
CLOSE OUTCHN, ;Let go of file.
CALL WRASCZ↑,<[[ASCIZ/(Old file)/]]>,ERMSOP
PLSASK: MOVE RET,CMDOP ;Can we ask?
CAME RET,[PUSHJ P,CMDGET]
JRST TAKEIT ; No, just go ahead.
CALL CONFRM ;Ask for confirmation.
JUMPE RET,TAKE2
JUMPL RET,[
SKIPE DELFLAG
JRST[ MOVE RET,NTAKEN ;Can't refer to stack in WARNMSG
PUSHJ P,WARNMSG
ERRARG TXT,[ASCIZ/DELETE aborted after removing /]
ERRARG DEC,RET
ERRARG TXT,[ASCIZ/ files./]
ERRARG CRLF,0
0
JRST FLUSH ]
CALL WRASCZ,<[[ASCIZ/RETRIEVE aborted by user.
/]]>,ERMSOP
FLUSH: SETOM NOTWILD
SETOM NTAKEN
JRST SKPFIL ]
SKIPIT: CALL WRASCZ↑,<[[ASCIZ/ File skipped.
/]]>,ERMSOP
JRST SKPFIL
; ---
TAKEIT: CALL WRASCZ,<[[ASCIZ/
/]]>,ERMSOP
TAKE2: SKIPE DELFLAG ;Deletion?
JRST DODEL ; Yes, this part of negotiation
printx Need to check for *'s in destination of RETRIEVE
ENTER OUTCHN,OUTFILE ;Now, really try to write it.
JRST[ CALL WARNMSG
ERRARG TXT,[ASCIZ/ENTER failed. /]
0
JRST SKIPIT ]
; \ /
;OK, we have the file open and ready for input. Tell other end.
CALL SNDMK2,<[MKYES]>,<[0]>,<[[ASCIZ/Ready for file./]]>
L5: CALL GETMRK ;Get their response
CAIN RET,MKCOMM ;Remark?
JRST[ CALL USRLMS,<[TXSPRE]> ;Yes, print it
JRST L5 ] ;and back for more
CAIN RET,MKNO ;Complaint?
JRST[ ; Yes!
GOTNO: RELEASE OUTCHN,3 ;Flush attempt at writing file.
CALL PUPGET ;Consume error code
CALL UNEXMK ; Unexpected mark or EOF
CALL SUSPND ;Bad files stop things
CALL USRLMS,<[TXSPRE]> ;Print complaint
JRST SKIPIT ] ;And skip it.
CAIE RET,MKFILE ;Is this our file?
JRST[ RELEASE OUTCHN,3 ;No! Flush new file:
CALL CNTXER ; No, a mistrake
RETURN ]
CALL PLGET,PLST,<[P.EOLC]> ;Get end of line convention
SKIPN RET ;Did other end supply it?
PUSHJ P,EOLHAK ; Curse, and continue
SETOM RET2 ;Assume CR
CAIE RET,ELCRLF ;CRLF
CAIN RET,ELTRNS ; or Transparent?
SETZM RET2 ; Yes, don't convert
SKIPN RET,U.TYPE ;Get type of transfer, if specified
MOVEI RET,TYPE.T ; If none, assume type Text
PUSHJ P,[
LSH RET,9 ;Set combined type for DORCV
IOR RET,U.BYTE ;Include byte size
POPJ P,]
CALL DORCV,RET2,RET ;Do transfer
SKIPE RET ;Errors?
MOVE RET,RET2 ; Yes, keep message (else 0)
PUSHP RET ;Save it on the stack
JUMPE RET,NOERRS
IFLUSH: CALL PUPGET ;Flush input buffer
SKIPA
JRST IFLUSH
; \ /
NOERRS: CALL GETMRK ;Get termination
CAIN RET,MKNO ;Any errors?
JRST GOTNO ; Yes, flush file.
CAIE RET,MKYES ;Proper termination?
JRST[ RELEASE OUTCHN,3
PUSHJ P,WARNMSG
ERRARG TXT,[ASCIZ/Transfer terminated with bad mark code '/]
ERRARG OCT,RET
ERRARG CRLF,0
JRST GETWIZ ]
CALL USRLMS,<[TXSPRE]>
POPP RET ;Get back message, if any, for error
JUMPN RET,[ ;Jump if any errors on our end
RELEASE OUTCHN,3
PUSHJ P,WARNMSG ;Print message
ERRARG TXT,[ASCIZ/Transfer failed. /]
ERRARG TXT,<(RET)>
ERRARG CRLF,0
0
JRST FLUSH ]
CLOSE OUTCHN, ;We actually finished!
AOS NTAKEN ;Count files completed.
;;;Let them have the privledge of saying it.
;;; CALL WRASCZ,<[[ASCIZ/Transfer complete.
;;;/]]>,ERMSOP
CALL WRINT↑,BAUDRT,<[=10]>,ERMSOP
CALL WRASCZ,<[[ASCIZ" Bits/sec.
"]]>,ERMSOP
JRST SKPFI2
; ---
SKPFIL: CALL SNDMK2,<[MKNO]>,<[RCNORE]>,<[[ASCIZ/Not that file, thanks./]]>
SKPFI2: CALL RLPLST,PLST
AOS FILCNT ;Count them, whether we use them or not!
JRST L2
;Last part of deletion, send YES and read one back.
DODEL: CALL SNDMK2,<[MKYES]>,<[0]>,<[[ASCIZ/Please delete this file./]]>
DELLP: CALL GETMRK ;Get their response
CAIN RET,MKCOMM ;Comment?
JRST[ CALL USRLMS,<[TXSPRE]> ;Yes, print it
JRST DELLP ] ;and back for more
CAIN RET,MKNO ;Error?
JRST[ CALL PLGET,PLST,<[P.SFIL]>
CALL WARNMSG
ERRARG TXT,[ASCIZ/Delete failed: /]
ERRARG TXT,<(RET)>
ERRARG CRLF,0
0
CALL USRLMS,<[TXSPRE]>
JRST SKPFI2 ] ;Print their complaint and look for more
AOS NTAKEN ;Assume the worst.
CAIE RET,MKYES ;Success?
JRST[ CALL CNTXER ; No, we got something unexpected!
PUSHJ P,WARNMSG
ERRARG TXT,[ASCIZ/Aborting DELETE. /]
ERRARG DEC,NTAKEN
ERRARG TXT,[ASCIZ/ files deleted (with last one uncertain)./]
ERRARG CRLF,0
0
JRST FLUSH ]
CALL USRLMS,<[TXSPRE]> ;Let their message be the indication.
JRST SKPFI2 ;Go look for more files.
QMKRET: CALL WRASCZ,<[[ASCIZ/?
/]]>,ERMSOP
POPJ P,
SUBREND USRETR
;Kludge to use user specified EOL convention when other end didn't say
EOLHAK: SKIPN RET,U.TYPE ;Do we have a type yet?
JRST EOLHK2 ; No, default is text. Worry some more
CAIE RET,TYPE.T ;TEXT
CAIN RET,TYPE.S ;or SAIL variant???
SKIPA
POPJ P, ; No, we don't care about EOLC
EOLHK2: SKIPN RET,U.EOLC
POPJ P,
OUTSTR[ASCIZ/[Foreign site didn't send EOL-Convention, CRLF handling may not be correct.]
/]
CALL SYBSRH,RET,<[ELNMTB]>
POPJ P,
SUBR USSTOR ;User Store
;------------------------------------------------------------------------------
;
; STORE Send one or more files.
;
;------------------------------------------------------------------------------
LOCALS{SRCLST}
ACCUMULATORS{TMP,PL,FL,ERRP}
WILDSW←←1B18 ;May be sending more than one file
ASKSW←←1B19 ;Confirm sending file.
SEENSW←←1B35 ;At least one file was found.
PUSHACS ;We're doing an ERRSET type of thing
; therefore, we must save everything
PUSHP <[ERRDON]> ;Where to return in case of errors
MOVE ERRP,P ;Save stack pointer to use for errors.
HRRI FL,ASKSW!WILDSW ;Initialize flags we may need
CALL RDSTRB,<[FILBRK]>,CMDOP ;Look for a file name
CAIN RET2,"←" ;Wrong arrow?
JRST[
CNFUSD: PUSHJ P,WARNMSG
ERRARG TXT,[ASCIZ/RETR localfile→serverfile>/]
ERRARG CRLF,0
0
RETURN ]
CAIE RET2,"→" ;Separate WAITS file name present?
CAIN RET2,"="
JRST[ PUSHP <[POINT 7,NAMBUF]> ;Yes
MOVEI RET,(P) ;Make a stream pointer to NAMBUF
HRLI RET,(<ILDB RET,>)
CALL RDIOSP,<[INBLK+1]>,RET,<[0]> ;Try parsing name
JRST[ PUSHJ P,WARNMSG
ERRARG TXT,[ASCIZ/Couldn't parse local file name./]
ERRARG CRLF,0
0
RETURN ]
POPP <(P)> ;Flush stream pointer for stack.
CALL RDSTRB,<[LINBRK]>,CMDOP ;Now, read server filename
TRZ FL,WILDSW ;Output is not a wild card.
JRST .+1]
CALL CMDTRM ;Command terminated normally?
SKIPA
JUMPN RET,NAMEOK ; Yes, assuming there was something there
PUSHJ P,WARNMSG
ERRARG TXT,[ASCIZ/Illegal terminator: /]
ERRARG CHR,RET2
ERRARG CRLF,0
0
RETURN
; ---
NAMEOK: MOVE RET,CMDOP ;Get stream we're reading from
CAME RET,[PUSHJ P,CMDGET] ;Can we ask?
TRZ FL,ASKSW ; No, forget it!
TRNN FL,WILDSW ;Wild card mode?
JRST NOTWLD ; No, go open device
CALL PLSTSL,<[FAKEPL]> ;Get search list from NAMBUF
JUMPE RET,[PUSHJ P,WARNMSG ;No match possible.
ERRARG TXT,[
ASCIZ/Wild card file expression can't match anything./]
ERRARG CRLF,0
0
JRST DONE]
JUMPL RET,[PUSHJ P,WARNMSG ;Print complaint and we're done
ERRARG TXT,<(RET2)>
ERRARG CRLF,0
0
JRST DONE ]
MOVEM RET,SRCLST ;Save search list
MOVEM RET2,MFDBLK+1 ;Set device name in lots of places.
MOVEM RET2,UFDBLK+1
MOVEM RET2,INBLK+1
MOVEM RET2,FAKDEV ;For SNDLPL to print device.
NOTWLD: SETZM INBLK ;Set type of open
CALL INOPEN ;Once more for the file.
JRST[ PUSHJ P,WARNMSG
ERRARG TXT,[ASCIZ/Cannot open device: /]
ERRARG SIX,INBLK+1
ERRARG CRLF,0
0
JRST DONE ]
TRNN FL,WILDSW ;Wild card?
JRST[ CALL GOTFI1,<[0]> ;No, no need for search list stuff
JRST DONE ]
CALL UFDOPN ;Do OPEN a second time
PUSHJ P,DRYROT ; This can't happen for any normal device.
CALL MFDOPN ;Open device
PUSHJ P,DRYROT ; This can't happen for any normal device.
MOVE RET,MFDFIL ;MFD has strange property of filename=ppn
MOVEM RET,MFDFIL+3
LOOKUP MFDCHN,MFDFIL
JRST[ PUSHJ P,WARNMSG
ERRARG TXT,[ASCIZ/Cannot read MFD (probably not directory device): /]
ERRARG SIX,INBLK+1
ERRARG CRLF,0
0
JRST DONE ]
MOVE RET,SRCLST ;Make special case check for single PPN
SETCM RET2,SNOFFS(RET) ;Look at file name only
CAMN RET2,SNONS(RET)
JRST[ MOVEM RET2,UFDBUF ;Set name of UFD
HLRZ RET2,SNNEXT(RET) ;Get list of files under it
JUMPE RET2,DONE ;"Can't happen"
HRRZ RET,(RET) ;Is there more than one UFD on this list?
JUMPN RET,.+1 ; Yes, probably must search MFD (sigh...)
;*** check protection here if user is ever becomes privledged.
; CALL CHKPRO,PLST,<[MFDBLK+1]>,<[A.STAT]> ;(?)
; ;Check protection to get side effect of verifying
; ;user name. GOTUFD will do the rest.
CALL GOTUFD,SRCLST ;Search this UFD
JRST DONE ]
CALL MAPSL,SRCLST,<[PUSHJ P,MFDWRD]>,<[GOTUFD]>
;For each matching directory...
; \ /
DONE: TRNN FL,SEENSW ;Was at least one file seen?
PUSHJ P,[ PUSHJ P,WARNMSG ;No, indicate lossage to user
ERRARG TXT,[ASCIZ/No such file(s)./]
ERRARG CRLF,0
0
POPJ P,]
POPP <(P)> ;Flush error return from stack
ERRDON: POPACS ;Restore original ACs
RELEASE MFDCHN, ;Don't need to reference these anymore
RELEASE UFDCHN,
RELEASE INCHN,
SKIPN SRCLST ;Search list present?
RETURN ; No, we're done
CALL RLSL,SRCLST ;Recover space from search list
RETURN
;Found a UFD, search it (one argument on the stack)
;(CAUTION: You can't make symbolic stack references here.)
GOTUFD: MOVE RET,UFDBUF ;Copy parameters for LOOKUP
MOVEM RET,UFDFIL
MOVE RET,MFDFIL ;Reset PPN for all needing
MOVEM RET,UFDFIL+3
HLRZ RET,@-1(P) ;Get sublist
JUMPE RET,[pushj p,dryrot ;No files: "Can't happen"
JRST GOTUF9] ;None, ignore this
LOOKUP UFDCHN,UFDFIL ;Open the UFD
JRST[
ILUFDR: CALL WRASCZ↑,<[[ASCIZ/Protection failure: /]]>,ERMSOP
CALL WRIOSP↑,<[UFDBLK+1]>,ERMSOP
CALL SUSPND ;Obviously losing.
JRST GOTUF9 ]
MOVE RET2,UFDFIL ;PPN
MOVEI TAC,A.STAT
REPEAT 0,< ;We don't need this unless user is runned priviledged
PUSHJ P,GRPCHK ;Decide if we have owner to UFD
MOVE RET,UFDFIL+2 ;Setup protection
PUSHJ P,ACCCHK ;Check for access at all
JRST ILUFDR ; Can't read that UFD.
>;REPEAT 0
HLRZ RET,@-1(P) ;Get sublist again.
CALL MAPSL,RET,<[PUSHJ P,UFDWRD]>,<[GOTFIL]>
;For each matching file in directory...
GOTUF9: POP P,-1(P) ;Flush one argument and return.
POPJ P,
;Got a file. Print information about it. (CAUTION: You can't make symbolic
;stack references here.)
GOTFIL: MOVE RET,[XWD UFDBUF,INFILE]
BLT RET,INFILE+2 ;Copy file for LOOKUP block
MOVE RET,UFDFIL
MOVEM RET,INFILE+3 ;Fill in PPN
MOVN RET,UFDBUF+4 ;Make it look like a LOOKUP block
MOVSM RET,UFDBUF+3 ;See, it's a negative swapped word count!
SETZM UFDBUF+4 ;Suppress PPN sent to server
GOTFI1: TRO FL,SEENSW ;Indicate we've seen at least one file.
CALL WRIOSP↑,<[INBLK+1]>,ERMSOP
;Print file name for user.
;Another place to check protection if user is ever run privledged.
LOOKUP INCHN,INFILE
JRST[ CALL WRASCZ,<[[ASCIZ/ - File not found or inaccessable.
/]]>,ERMSOP
CALL SUSPND ;Obviously losing.
JRST FILDON ]
CALL WRASCZ↑,<[[ASCIZ/ to /]]>,ERMSOP
CALL SNDMRK,<[MKNSTO]> ;Setup to send file.
TRNE FL,WILDSW ;Was destination file specified?
JRST[ CALL SNDLPL,<[UFDBUF-INFILE+INBLK+1]>,<[SNDUNM]>
;No. Send property list from our file and
; user requested information
JRST GOTFI2 ]
PUSHP <[POINT 7,NAMBUF]>
MOVEI RET,(P) ;Yes, send property list from command line
HRLI RET,(<ILDB RET,>)
CALL SNDUPL,RET,<[SNDUNM]> ;Send property list from user's input
POPP <(P)> ;Flush stream pointer for stack.
GOTFI2: CALL SNDMRK,<[MKEOC]> ;Terminate request
GOTFI3: CALL GETMRK ;Wait for response
CAIN RET,MKCOMM ;Comment
JRST[ CALL USRLMS,<[TXSPRE]> ;Yes, print it
JRST GOTFI3 ] ;and back for more
CAIN RET,MKNO ;Complaint?
JRST[ CALL PUPGET ;Yes, ignore number
CALL UNEXMK ; Unexpected mark or EOF
CALL PRNQMK ;Print (?)<return>
CALL USRLMS,<[TXSPRE]>
CALL SUSPND ;Inability to write suspends
CALL GETMRK ;Get termination
CAIE RET,MKEOC
CALL NOEOC
JRST NOFILE ]
CAIE RET,MKPLST ;A file?
JRST[ CALL PRNQMK ; No, Print (?)<return>
CALL CNTXER ; Complain bitterly
JRST NOFILE ]
CALL RDPLST,PUPROP ;Read property list
JUMPE RET,[CALL PRNQMK ; Bad. Print (?) then error
TLNN RET2,-1 ;Is there an error message?
HRLI RET2,[ASCIZ/Empty property list./] ;No, make one
HLRZ RET,RET2
PUSHJ P,WARNMSG
ERRARG TXT,TXFHSN
ERRARG TXT,<@RET>
ERRARG TXT,[ASCIZ/ Terminator = /]
ERRARG CHR,RET2
ERRARG CRLF,0
0
JRST NOFILE] ;Keep going...
MOVEM RET,PL ;Save pointer to property list
CALL GETMRK ;Get terminating EOC
CAIE RET,MKEOC
CALL NOEOC
CALL PLGET,PL,<[P.SFIL]> ;Get name of file
JUMPE RET,[CALL PLGET,PL,<[P.NAMB]>
JUMPN RET,.+1
CALL PRNQMK ;Print (?)<return>
PUSHJ P,WARNMSG
ERRARG TXT,[ASCIZ/Recieved property list with no filename property!/]
ERRARG CRLF,0
0
JRST NOFILE]
CALL WRASCZ↑,RET,ERMSOP ;Print file name
printx USSTOR needs to know how to print (Old file) or (New file)
TRNN FL,ASKSW ;Are we asking about each file?
JRST[ ; No, skip it
CALL WRASCZ,<[[ASCIZ/
/]]>,ERMSOP
JRST NOASK ]
call wrascz↑,<[[asciz/ (Confirm)/]]>,ermsop ;DUE TO LACK OF NEW/OLD FILE
CALL CONFRM ;Skip if confirmed.
JUMPG RET,[CALL DOSKIP
CALL WRASCZ,<[[ASCIZ/ File skipped.
/]]>,ERMSOP
JRST FILDON]
JUMPL RET,[CALL WRASCZ,<[[ASCIZ/STORE aborted by user.
/]]>,ERMSOP
CALL DOSKIP
JRST NOFILE]
; \ /
;Already to send file. Now, do it!
NOASK: CALL SNDMRK,<[MKFILE]> ;Now, send file!
CALL PLGET,PL,<[P.EOLC]> ;Get end of line convention
SKIPN RET ;None given?
PUSHJ P,EOLHAK ; Curse, and continue
SETOM RET2 ;Assume CR
CAIE RET,ELCRLF ;CRLF
CAIN RET,ELTRNS ; or Transparent?
SETZM RET2 ; Yes, don't convert
SKIPN RET,U.TYPE ;Get type of transfer, if specified
MOVEI RET,TYPE.T ; If none, assume type Text
PUSHJ P,[
LSH RET,9 ;Set combined type for DOSND
IOR RET,U.BYTE ;Include byte size
POPJ P,]
CALL DOSND,RET2,RET
JUMPN RET,[ ;Jump if errors seen
CALL WARNMSG
ERRARG TXT,[ASCIZ/Transfer failed. /]
ERRARG TXT,<(RET2)>
ERRARG CRLF,0
0
CALL SNDMK2,<[MKNO]>,RET,RET2
NOSND2: CALL GETMRK ;Wait for response
CAIN RET,MKCOMM
JRST[ CALL USRLMS,<[TXSPRE]>
JRST NOSND2 ]
CAIE RET,MKNO ;Better be a NO
CALL CNTXER
CALL PUPGET ;Flush reply code
CALL UNEXMK
CALL USRLMS,<[TXSPRE]> ;Print confirmation of abort
CALL GETMRK
CAIE RET,MKEOC ;Make sure it's properly terminated.
CALL NOEOC
JRST FILDON ]
CALL SNDMK2,<[MKYES]>,<[0]>,RET2 ;DOSND has the message
GOTFI7: CALL GETMRK ;Get confirmation from other end.
CAIN RET,MKCOMM ;Comment?
JRST[ CALL USRLMS,<[TXSPRE]> ;Yes, print it
JRST GOTFI7 ] ;and back for more
CAIN RET,MKNO ;Error?
JRST[ CALL WRASCZ↑,<[[ASCIZ/Transfer failed:
/]]>,ERMSOP
CALL SUSPND ;Write errors on other end suspends
JRST GOTFI8 ] ;Print their complaint and look for more
CAIE RET,MKYES ;Success?
JRST[ CALL CNTXER ; No, we got something unexpected!
JRST FILDON ]
GOTFI8: CALL PUPGET ;Flush reply code
CALL UNEXMK ; Unexpected mark or EOF
CALL USRLMS,<[TXSPRE]> ;Let their message be the indication.
CALL GETMRK ;Read termination
CAIE RET,MKEOC ;Better be EOC
CALL NOEOC ; Sigh...
CALL WRINT↑,BAUDRT,<[=10]>,ERMSOP
CALL WRASCZ,<[[ASCIZ" Bits/sec.
"]]>,ERMSOP
FILDON: CLOSE INCHN, ;Done with file, if it was even open
POP P,-1(P) ;Flush one argument and return
POPJ P,
;Skip a file.
DOSKIP: CALL SNDMK2,<[MKNO]>,<[RCNOST]>,<[[ASCIZ/No, thank you./]]>
DOSKP2: CALL GETMRK ;Get confirmation of NO we just sent
CAIN RET,MKCOMM ;Comment?
JRST[ CALL USRLMS,<[TXSPRE]> ;Consume and print comment
JRST DOSKP2 ]
CAIE RET,MKNO ;Was it?
CALL CNTXER ; No, complain.
CALL PUPGET ;Flush reply code
CALL UNEXMK ; Unexpected mark or EOF
CALL USRLMS,<[TXSPRE]> ;Print message to confirm.
CALL GETMRK
CAIE RET,MKEOC ;And terminating EOC?
CALL NOEOC
POPJ P,
;We get here when we decide things are real grim and we want out.
NOFILE: MOVE P,ERRP ;Restore old stack pointer
POPJ P, ;Return to someone who can help.
PRNQMK: PUSHP RET ;Save ACs while printing this, they may contain
PUSHP RET2 ; information about the error.
CALL WRASCZ↑,<[[ASCIZ/(?)
/]]>,ERMSOP
POPP RET2
POPP RET
POPJ P,
SUBREND USSTOR
SUBR USLIST ;LIST command (also USNLST for NLST)
;------------------------------------------------------------------------------
;
; LIST List directory
; NLST Short form of List
;
;------------------------------------------------------------------------------
TDZA RET,RET ;Remember which kind we are doing
↑USNLST: MOVEI RET,1
LOCALS{FILCNT,SHORT,PLST}
LOCALS{OUTOP}
MOVEM RET,SHORT
MOVE RET,[PUSHJ P,[AOS TYOPOS
XCT ERMSOP
POPJ P,]]
MOVEM RET,OUTOP
printx LIST/NLST needs to be able to send output to a file.
CALL SNDMRK,<[MKDIR]> ;Request directory
CALL SNDUPL,CMDOP,<[SNDUNM]> ;Send property list from user's input
CALL SNDMRK,<[MKEOC]> ;Terminate request
L1: CALL GETMRK ;Wait for response
CAIN RET,MKCOMM ;Comment
JRST[ CALL USRLMS,<[TXSPRE]> ;Yes, print it
JRST L1 ] ;and back for more
CAIN RET,MKNO ;Complaint?
JRST[ CALL PUPGET ;Yes, ignore number
CALL UNEXMK ; Unexpected mark or EOF
CALL USRLMS,<[TXSPRE]>
;;; CALL SUSPND ;Directory lists don't suspend [so far]
CALL GETMRK ;Get termination
CAIE RET,MKEOC
CALL NOEOC
RETURN ]
CAIN RET,MKEOC ;End of list?
JRST[ SKIPE FILCNT ;Any files seen?
RETURN
CALL WRASCZ↑,<[[ASCIZ/(Server sent empty list in response to directory request.)
/]]>,ERMSOP
CALL SUSPND ;This is wierd enough to stop things
RETURN ]
CAIE RET,MKPLST ;A file?
JRST[ CALL CNTXER ; No, a mistrake
RETURN ]
CALL RDPLST,PUPROP ;Read property list
JUMPE RET,[TLNN RET2,-1 ;Is there an error message?
HRLI RET2,[ASCIZ/Empty property list./] ;No, make one
HLRZ RET,RET2
PUSHJ P,WARNMSG
ERRARG TXT,TXFHSN
ERRARG TXT,<@RET>
ERRARG TXT,[ASCIZ/ Terminator = /]
ERRARG CHR,RET2
ERRARG CRLF,0
0
JRST L1] ;Keep going...
MOVEM RET,PLST ;Save pointer to property list
CALL PLGET,RET,<[P.SFIL]> ;Get name of file
JUMPE RET,[CALL PLGET,PLST,<[P.NAMB]>
JUMPN RET,.+1
PUSHJ P,WARNMSG
ERRARG TXT,[ASCIZ/Recieved property list with no filename property!/]
ERRARG CRLF,0
0
JRST SKPFIL]
SETZM TYOPOS ;Setup tabbing kludge
CALL WRASCZ↑,RET,OUTOP ;Print file name
SKIPE SHORT ;Short form?
JRST SKPRST
TABLP: MOVEI RET,7
IORM RET,TYOPOS
MOVEI RET," " ;Tab after name
XCT OUTOP
MOVE RET,TYOPOS
CAIGE RET,=24
JRST TABLP
CALL PLGET,PLST,<[P.SIZE]> ;Get size of file
JUMPE RET,SKPSIZ
CALL WRASCZ↑,RET,OUTOP ;Print size in bytes
SKPSIZ: MOVEI RET," " ;Tab after name
XCT OUTOP
CALL PLGET,PLST,<[P.WDAT]> ;Get date last written
JUMPE RET,[MOVEI RET," " ;Need an extra tab if we skip this
;;; XCT OUTOP
JRST SKWDAT]
CALL WRASCZ↑,RET,OUTOP ;Print date last written
SKWDAT:
SKPRST: CALL WRASCZ↑,<[[ASCIZ/
/]]>,OUTOP ;Terminate string
SKPFIL: CALL RLPLST,PLST
AOS FILCNT ;Count them, whether we use them or not!
JRST L1
SUBREND USLIST
SUBR USMLFL ;Send Mail file
;------------------------------------------------------------------------------
;
; MLFL Send a mail file.
;
;------------------------------------------------------------------------------
CALL RDSTRB,<[FILBRK]>,CMDOP ;Look for a file name
CAIN RET2,"←" ;Wrong kind of arrow?
JRST CNFUSD ;Yes, must have files wrong, too
CAIE RET2,"→" ;Separate WAITS file name present?
CAIN RET2,"="
JRST[ PUSHP <[POINT 7,NAMBUF]>
MOVEI RET,(P) ;Make a stream pointer to NAMBUF
HRLI RET,(<ILDB RET,>)
CALL RDIOSP,<[INBLK+1]>,RET,<[0]>
JRST[ PUSHJ P,WARNMSG
ERRARG TXT,[ASCIZ/Couldn't parse local file name./]
ERRARG CRLF,0
0
RETURN ]
POPP <(P)> ;Flush stream pointer for stack.
CALL RDSTRB,<[LINBRK]>,CMDOP ;Now, read user name
CALL CMDTRM ;Terminated normally?
SKIPA
JUMPN RET,NAMEOK ; Yes, if non-null
PUSHJ P,WARNMSG
ERRARG TXT,[ASCIZ/Illegal terminator: /]
ERRARG CHR,RET2
ERRARG CRLF,0
0
RETURN ]
CNFUSD: PUSHJ P,WARNMSG
ERRARG TXT,[ASCIZ/MLFL localfile→username/]
ERRARG CRLF,0
0
RETURN
; ---
NAMEOK: SETZM INBLK ;Set type of open
CALL INOPEN ;First order of business is reading the file
JRST[ CALL WARNMSG
ERRARG TXT,[ASCIZ/Can't open device: /]
ERRARG SIX,INBLK+1
ERRARG CRLF,0
0
RETURN ]
LOOKUP INCHN,INFILE ;Can we find it?
JRST[ CALL WARNMSG ; Ooops.
ERRARG TXT,[ASCIZ/File not found: /]
0
CALL WRIOSP,<[INBLK+1]>,ERMSOP
CALL WRASCZ,<[[ASCIZ/
/]]>,ERMSOP
RELEAS INCHN,
RETURN ]
; \ /
;Now, we have the file open, invent a property list out of thin air
CALL SNDMRK,<[MKSMAI]> ;Store Mail
CALL OPNPRN
CALL BEGPRP,<[TXMLBX]>
CALL WRASCZ,<[NAMBUF]>,PUPQCK ;Send name, checking for specials
;Possible bug. We flush spaces here.
CALL CLSPRN
CALL BEGPRP,<[TXSNDR]>
GETPPN RET, ;Get user's PPN
HRLZ RET,RET ;Extract user name
CALL WRSIX,RET,PUPQCK ;Send that down the line.
CALL WRASCZ,<[TXATSI]>,PUPWOP ;And site name
CALL CLSPRN
CALL CLSPRN
CALL SNDMRK,<[MKEOC]> ;Terminate list of property list.
L1: CALL GETMRK ;Now, let's see what they think about
;this.
L2: CAIN RET,MKCOMM ;Print any remarks
JRST[ CALL USRLMS,<[TXSPRE]>
JRST L1 ]
CAIN RET,MKMBEX ;Any mailbox exceptions?
JRST[ CALL PUPGET ;Yes, flush type
CALL UNEXMK ; Unexpected mark or EOF
CALL PUPGET ;Flush index
CALL UNEXMK ; Unexpected mark or EOF
CALL WARNMSG
ERRARG TXT,[ASCIZ/Can't send to that mailbox:/]
ERRARG CRLF,0
0
CALL USRLMS,<[TXSPRE]>
CALL GETMRK ;Get next thing, to check for EOC
CAIE RET,MKEOC ;Did we get it?
JRST L2 ; No. Good, we shouldn't
RELEASE INCHN, ;Flush file we were reading.
RETURN ]
CAIN RET,MKNO ;Rejection?
JRST[ CALL PUPGET ;Yes, flush type
CALL UNEXMK ; Unexpected mark or EOF
CALL WARNMSG
ERRARG TXT,[ASCIZ/Can't send mail:/]
ERRARG CRLF,0
0
CALL USRLMS,<[TXSPRE]>
CALL GETMRK ;Get next thing, to check for EOC
CAIE RET,MKEOC ;Did we get it?
CALL NOEOC ; No. Sigh...
RELEASE INCHN, ;Flush file we were reading.
RETURN ]
CAIE RET,MKYES ;If none of above, must be YES
JRST[ CALL CNTXER ;Ooops!
RELEASE INCHN,
RETURN ]
CALL PUPGET ;Consume type
CALL UNEXMK ; Unexpected mark or EOF
CALL USRLMS,<[TXSPRE]> ;Consume and print message.
CALL GETMRK ;Consume EOC
CAIE RET,MKEOC ;It better be one.
CALL NOEOC ; Ooops
CALL SNDMRK,<[MKFILE]> ;Now, send text.
PUSHP INERRS ;A check against errors on our part
printx USMLFL Still using old form for DOSND
CALL DOSND,<[1]>,<[0]> ;CR-only, not binary
RELEASE INCHN, ;Flush file we were reading.
POPP RET ;Get back error count
CAME RET,INERRS ;Check for errors
JRST[ CALL SNDMK2,<[MKNO]>,<[RCFDER]>,<[
[ASCIZ/Don't send mail, local device error./]]>
jrst L3] ;See what they say in reply
CALL SNDMK2,<[MKYES]>,<[0]>,<[[ASCIZ/End of mail transfer./]]>
L3: CALL GETMRK ;Get acknowledgement
L4: CAIN RET,MKMBEX ;Any mailbox exceptions?
JRST[ CALL PUPGET ;Yes, flush type
CALL UNEXMK ; Unexpected mark or EOF
CALL PUPGET ;Flush index
CALL UNEXMK ; Unexpected mark or EOF
CALL WARNMSG
ERRARG TXT,[ASCIZ/Can't send to that mailbox:/]
ERRARG CRLF,0
0
CALL USRLMS,<[TXSPRE]>
CALL GETMRK ;Get next thing, to check for EOC
CAIE RET,MKEOC ;Did we get it?
JRST L4 ; No. Good, we shouldn't
RETURN ]
CAIN RET,MKNO ;Complaint?
JRST[ CALL WARNMSG
ERRARG TXT,[ASCIZ/Can't send mail:/]
ERRARG CRLF,0
0
ENDMAI: CALL PUPGET ;Yes, ignore number
CALL UNEXMK ; Unexpected mark or EOF
CALL USRLMS,<[TXSPRE]>
CALL GETMRK ;Get termination
CAIE RET,MKEOC
CALL NOEOC
RETURN ]
CAIN RET,MKYES ;Success?
JRST ENDMAI ; Yes.
CAIN RET,MKCOMM
JRST[ CALL USRLMS,<[TXSPRE]>,ERMSOP
JRST L4 ]
CALL CNTXER ;We're confused.
RETURN
DEFINE .TTL(SITE,VERNUM,DATE)
< ASCIZ/ at SITE/
>
TXATSI: VERINF
SUBREND USMLFL
SUBR USRLMS,PREAMB ;Log/flush message in user mode
COMMENT ⊗ ---------------------------------------------------------------------
Calling Sequence:
PUSH P,[<address of string>]
PUSHJ P,USRLMS
Returns:
Undefined
Description:
Logs human readable messages if server debugging is enabled. Otherwise,
simply flushes them.
Calls:
WRASCZ,PIPEIT
Side effects:
Clobbers RET
Flushes PUP stream to next mark.
⊗;------------------------------------------------------------------------------
SKIPN UDEBUG ;Logging messages today?
JRST NOMSG ; No, just flush 'em
CALL WRASCZ↑,PREAMB,ERMSOP
CALL PIPEIT,PUPROP,ERMSOP
;Copy from input stream to output stream
CALL WRASCZ↑,<[[ASCIZ/
/]]>,ERMSOP ;Make sure line gets terminated
RETURN
;Not logging messages, flush human readable string
NOMSG: XCT PUPROP ;Flush out stream
JUMPN RET,NOMSG
RETURN
SUBREND USRLMS
SUBR CONFRM ;Ask user for confirmation
printx --- CONFRM needs work!
PUSHP RET2
LOOP: CALL BSBEG ;Permit backspace at beginning of line
CALL RDSTRB,<[LINBRK]>,CMDOP
CALL BSNORM ;Back to normal mode.
CAIN RET2,175 ;Altmode to abort whole thing?
JRST[ CALL WRASCZ↑,<[[ASCIZ/
/]]>,ERMSOP
SETO RET,
JRST DONE ]
CAIN RET2,15
PUSHJ P,[EXCH RET,RET2 ;Consume ubiquitous LF
XCT CMDOP
EXCH RET,RET2
POPJ P,]
ANDI RET2,177 ;Flush control bits.
CAIN RET2,177 ;Rubout
JRST[ CALL WRASCZ,<[[ASCIZ/
/]]>,ERMSOP ; Yes, skip just this one.
MOVEI RET,1
JRST DONE ]
CAIN RET2,12
JRST[ JUMPE RET,DONE ;No argument means OK
LDB RET,[POINT 7,NAMBUF,6]
CAIE RET,"N" ;NO
CAIN RET,"n"
JRST[ MOVEI RET,1
JRST DONE ]
CAIE RET,"H" ;Probably said HELP
CAIN RET,"h"
JRST HELPER
CAIN RET,"?" ;Another form of help
JRST[
HELPER: CALL WRASCZ↑,<[[ASCIZ/ <return> to accept.
<rubout> to reject.
<altmode> aborts
(Confirm): /]]>,ERMSOP
JRST LOOP ]
CAIE RET,"Y"
CAIN RET,"y"
TDZA RET,RET ;Another kind of OK
MOVEI RET,2
JRST DONE ]
CALL WARNMSG
ERRARG TXT,[ASCIZ/Bad terminator: /]
ERRARG CHR,RET2
ERRARG TXT,[ASCIZ/ Use <RUBOUT> to skip, <ALT> to abort./]
ERRARG CRLF,0
MOVEI RET,2
DONE: POPP RET2 ;Restore borrowed AC
RETURN
; ---
;Activate on rubout at beginning of line
BSBEG: PUSHJ P,BSSUBR
IORM RET,NEWACT+3
POPJ P,
;Deactivate rubout at beginning of line
BSNORM: PUSHJ P,BSSUBR
ANDCAM RET,NEWACT+3
POPJ P,
BSSUBR: PUSHP RET
MOVE RET,[OLDACT,,NEWACT]
SETACT RET
BLT RET,NEWACT+3
MOVEI RET,20 ;Active on RUBOUT at beginning of line
XCT @-1(P)
POPP RET
SETACT [OLDACT,,NEWACT]
AOS (P)
POPJ P,
SUBREND CONFRM
SUBR DORCV,CRONLY,BINARY ;Tranfer Remote -> Local
MSTIME RET, ;Get time of day in msec.
PUSHP RET
PUSHP TAC
PUSHP OUTERRS ;Setup to check for errors
MOVEI RET,OUTCHN
SHOWIT RET,
SETZM EIBYTS ;Start counting bytes
SKIPE RET,BINARY ;Binary?
JRST TRYBIN
; \ /
NORMTX: SKIPA TAC,[POINT 8,FRASCI(RET),35-4] ;ARPA FTP conversion
SAITXT: MOVE TAC,[POINT 8,FRASCS(RET),35-4] ;SAIL conversion
; \ /
TXTLP: CALL PUPGET ;Get byte from file
JRST[ MOVEI RET2,[ASCIZ/Text transfer complete. /]
JRST ERRCHK ]
JUMPE RET,TXTLP ;Flush nulls
TRNE RET,200 ;Is the extra bit on?
JRST[ MOVEI RET,RCTRSP ;Yes, they lose!
MOVEI RET2,[ASCIZ/Only 7 bit ASCII is implemented at SAIL./]
RETURN ]
CAIN RET,15 ;Is it CR?
JRST[ SKIPN CRONLY ; Do we have to check these?
JRST .+1 ; No, flush it
CALL PUTBYT
MOVEI RET,12
JRST .+1 ]
SETZ RET2, ;Construct byte pointer into conversion table
ASHC RET,-2
ADD RET2,TAC ;Add appropriate character table pointer
LDB RET,RET2 ;Fetch corresponding character
CALL PUTBYT
JRST TXTLP
;Note: Macro reverse 8 bit bytes within a word.
DEFINE CHMAP1(A0,A1,A2,A3,B0,B1,B2,B3,C0,C1,C2,C3,D0,D1,D2,D3) <
BYTE (8) A3,A2,A1,A0,B3,B2,B1,B0,C3,C2,C1,C0,D3,D2,D1,D0 >
;------------------------------------------------------------------------------
; Graphic Local Remote Name
;Normal:
; _ '30 '137 Underline
; ← '137 '30 Left arrow
; ≠ '33 '32 Not-equals
; <ALT> '175 '33 <ALT> (or <ESCAPE>)
;{ } '176 '175 Right brace
; ~ '32 '176 Tilde
;"SAIL":
; ≠ '33 '32 Not-equals
; <ALT> '175 '33 <ALT> (or <ESCAPE>)
;{ } '176 '175 Right brace
; ~ '32 '176 Tilde
;------------------------------------------------------------------------------
; NL ↓ α β ∧ ¬ ε π λ HT LF VT FF CR ∞ ∂
FRASCI: CHMAP1 0, 1, 2, 3, 4, 5, 6, 7, 10, 11, 12, 13, 14, 15, 16, 17
; ⊂ ⊃ ∩ ∪ ∀ ∃ ⊗ ↔ ← → ≠ ESC ≤ ≥ ≡ ∨
CHMAP1 20, 21, 22, 23, 24, 25, 26, 27,137, 31, 33,175, 34, 35, 36, 37
; SP ! " # $ % & ' ( ) * + , - . /
CHMAP1 40, 41, 42, 43, 44, 45, 46, 47, 50, 51, 52, 53, 54, 55, 56, 57
; 0 1 2 3 4 5 6 7 8 9 : ; < = > ?
CHMAP1 60, 61, 62, 63, 64, 65, 66, 67, 70, 71, 72, 73, 74, 75, 76, 77
; @ A C C D E F G H I J K L M N O
CHMAP1 100,101,102,103,104,105,106,107,110,111,112,113,114,115,116,117
; P Q R S T U V W X Y Z [ \ ] ↑ _
CHMAP1 120,121,122,123,124,125,126,127,130,131,132,133,134,135,136, 30
; ` a b c d e f g h i j k l m n o
CHMAP1 140,141,142,143,144,145,146,147,150,151,152,153,154,155,156,157
; p q r s t u v w x y z { | } ~ DEL
CHMAP1 160,161,162,163,164,165,166,167,170,171,172,173,174,176, 32,177
;------------------------------------------------------------------------------
; NL ↓ α β ∧ ¬ ε π λ HT LF VT FF CR ∞ ∂
FRASCS: CHMAP1 0, 1, 2, 3, 4, 5, 6, 7, 10, 11, 12, 13, 14, 15, 16, 17
; ⊂ ⊃ ∩ ∪ ∀ ∃ ⊗ ↔ _ → ≠ ESC ≤ ≥ ≡ ∨
CHMAP1 20, 21, 22, 23, 24, 25, 26, 27, 30, 31, 33,175, 34, 35, 36, 37
; SP ! " # $ % & ' ( ) * + , - . /
CHMAP1 40, 41, 42, 43, 44, 45, 46, 47, 50, 51, 52, 53, 54, 55, 56, 57
; 0 1 2 3 4 5 6 7 8 9 : ; < = > ?
CHMAP1 60, 61, 62, 63, 64, 65, 66, 67, 70, 71, 72, 73, 74, 75, 76, 77
; @ A C C D E F G H I J K L M N O
CHMAP1 100,101,102,103,104,105,106,107,110,111,112,113,114,115,116,117
; P Q R S T U V W X Y Z [ \ ] ↑ ←
CHMAP1 120,121,122,123,124,125,126,127,130,131,132,133,134,135,136,137
; ` a b c d e f g h i j k l m n o
CHMAP1 140,141,142,143,144,145,146,147,150,151,152,153,154,155,156,157
; p q r s t u v w x y z { | } ~ DEL
CHMAP1 160,161,162,163,164,165,166,167,170,171,172,173,174,176, 32,177
;------------------------------------------------------------------------------
;Some kind of binary, see what kind
TRYBIN: PUSHP TAC ;Save an AC while searching
TRNN RET,777 ;Bytesize defined?
TRO RET,=8 ; No, pick default bytesize
MOVSI RET2,-TYPDSZ ;Setup to search for appropriate routine
TRYBI2: HLRZ TAC,TYPDIS(RET2) ;Get type of binary
CAME RET,TAC ;Match?
AOBJN RET2,TRYBI2 ; No, continue looking
POPP TAC ;Restore borrowed AC
JUMPGE RET2,[
MOVEI RET,RCILBY
MOVEI RET2,[ASCIZ/We don't support that mode of binary./]
RETURN ]
HRRZ RET2,TYPDIS(RET2) ;Get address of routine
JRST (RET2) ;Do something about that type.
;Dispatch table for binary types for receive
TYPDIS: TYDSEN B,8,L8
TYDSEN B,32,L8 ;32 bit binary is same as 8 bit binary
TYDSEN B,36,L36 ;Funny Xerox 36 bit format
TYDSEN D,36,D36 ;PDP-10 dump mode
TYDSEN I,36,L72 ;Image mode
TYDSEN S,8,SAITXT ;SAIL
TYDSEN T,8,NORMTX ;Text
TYDSEN X,8,L8 ;Nothing special on recieve
TYDSEN X,32,L8
TYPDSZ←←.-TYPDIS ;Size of table in words.
;Left justified, 8 bit binary
L8: MOVEI RET,8 ;Force output byte size
DPB RET,[POINT 6,OUTHDR+1,11]
L8A: CALL PUPGET
JRST[ MOVEI RET2,[ASCIZ/Left justified binary transfer complete. /]
JRST ERRCHK ]
CALL PUTBYT
JRST L8A
;PDP-10 dump mode tape format
; -----------------------------------------------------------------------
;| | | | | |
;| Byte 1 | Byte 2 | Byte 3 | Byte 4 | |
;| | | | | |
; -----------------------------------------------------------------------
; ↓ ↓
; ----------------
; | |
; | Byte 5 |
; | |
; ----------------
D36: MOVEI RET,=36 ;Force output byte size
DPB RET,[POINT 6,OUTHDR+1,11]
D36A: CALL PUPGET ;Byte 1
JRST[ MOVEI RET2,[ASCIZ/36 bit dump mode transfer complete. /]
JRST ERRCHK ]
MOVE RET2,RET
CALL PUPGET ;Byte 2
JRST[
L36ER1:
D36ER1: MOVEI RET,RCTRSP
MOVEI RET2,[ASCIZ/Last word of 36 bit transfer was incomplete./]
RETURN ]
ROT RET2,8
ADDI RET2,(RET)
CALL PUPGET ;Byte 3
JRST D36ER1
ROT RET2,8
ADDI RET2,(RET)
CALL PUPGET ;Byte 4
JRST D36ER1
ROT RET2,8
ADDI RET2,(RET)
CALL PUPGET ;Byte 5
JRST D36ER1
ROT RET2,4
TRNE RET,360 ;Extra bits on?
JRST[ MOVEI RET,RCTRSP ;Yes, more than 4 bits on in stray bytes
MOVEI RET2,[ASCIZ/Improper bits on in stray byte of 36 bit transfer./]
RETURN ]
ADD RET,RET2 ;Assemble full word into RET
CALL PUTBYT ;Output a word
JRST D36A
; ----------------
;| |
;| Byte 1 |
;| |
; ----------------
; / /
; / /
; / /
; / /
; -----------------------------------------------------------------------
;| | | | | |
;| | Byte 2 | Byte 3 | Byte 4 | Byte 5 |
;| | | | | |
; -----------------------------------------------------------------------
L36: MOVEI RET,=36 ;Force output byte size
DPB RET,[POINT 6,OUTHDR+1,11]
L36A: CALL PUPGET ;Byte 1
JRST[ MOVEI RET2,[ASCIZ/36 bit binary transfer complete. /]
JRST ERRCHK ]
; TRNE RET,360 ;Extra bits on?
; JRST[ MOVEI RET,RCTRSP ;Yes, more than 4 bits on in stray bytes
; MOVEI RET2,[ASCIZ/Improper bits on in stray byte of 36 bit transfer./]
; RETURN ]
;printx Need to flush data stream if we get bad binary input.
MOVE RET2,RET
CALL PUPGET ;Byte 2
JRST L36ER1
LSH RET2,8
ADDI RET2,(RET)
CALL PUPGET ;Byte 3
JRST L36ER1
LSH RET2,8
ADDI RET2,(RET)
CALL PUPGET ;Byte 4
JRST L36ER1
LSH RET2,8
ADDI RET2,(RET)
CALL PUPGET ;Byte 5
JRST L36ER1
ROT RET2,8
TRNE RET2,17 ;Stray bits on?
JRST[ XOR RET2,RET ;Same bits as last byte?
TRNE RET2,17
JRST[ MOVEI RET,RCTRSP ;No, it's probably not 36 bit mode
MOVEI RET2,[ASCIZ/Improper bits on in stray byte of 36 bit transfer./]
RETURN ]
;printx Need to flush data stream if we get bad binary input.
TRZ RET2,377 ;Yes, losing T[W]ENEX PUPFTP
JRST .+1]
ADD RET,RET2 ;Assemble full word into RET
CALL PUTBYT ;Output a word
JRST L36A
;Stream mode, bits go into PDP-10 words in order received from the net (or do the
; 8 bit bytes have their bits reversed???)
L72: MOVEI RET,=36
IDPB RET,[POINT 6,OUTHDR+1,11]
L72A: CALL PUPGET ;Byte 1
JRST[ MOVEI RET2,[ASCIZ/Bit stream transfer complete. /]
JRST ERRCHK ]
ROT RET,-8
MOVE RET2,RET
CALL PUPGET ;Byte 2
JRST[ CALL PUTBYT
L72B: MOVEI RET,[ASCIZ/Bit stream transfer complete. /]
JRST ERRCHK ]
DPB RET,[POINT 8,RET2,15]
CALL PUPGET ;Byte 3
JRST L72B
DPB RET,[POINT 8,RET2,23]
CALL PUPGET ;Byte 4
JRST L72B
DPB RET,[POINT 8,RET2,31]
CALL PUPGET ;Byte 5
JRST L72B
ROT RET,4
DPB RET,[POINT 4,RET2,35] ;Half into first word
EXCH RET,RET2 ;and half into second word, and output first
CALL PUTBYT ;Output first word
CALL PUPGET ;Byte 6
JRST L72B
DPB RET,[POINT 8,RET,11]
CALL PUPGET ;Byte 7
JRST L72B
DPB RET,[POINT 8,RET,19]
CALL PUPGET ;Byte 6
JRST L72B
DPB RET,[POINT 8,RET,27]
CALL PUPGET ;Byte 6
JRST L72B
DPB RET,[POINT 8,RET,35]
MOVE RET2,RET ;Setup second word
CALL PUTBYT ;Output second word
JRST L72A
;Lastly, check for device errors.
;Jump here with completion string in RET2
ERRCHK: POPP RET ;Get number of errors before entering
POPP TAC ;Restore borrowed AC
CAME RET,OUTERRS ;Still the same?
JRST[ MOVEI RET,RCFDER ; No, we got a write error!
MOVEI RET2,[ASCIZ/Output error writing file./]
RETURN ]
MSTIME RET, ;Calculate elaped time
SUB RET,(P)
FSC RET,233
FDVRI RET,(1000.0) ;Convert to seconds
MOVEM RET,(P) ;Save on stack
MOVE RET,EIBYTS
FSC RET,233+3 ;Multiply by 8 to get number of bits
FDVR RET,(P)
KAFIX RET,233000
MOVEM RET,BAUDRT
POPP <(P)> ;Flush stack
SETZ RET, ;No errors
RETURN
SUBREND DORCV
SUBR DOSND,CRONLY,BINARY ;Transfer Local -> Remote
MSTIME RET, ;Get time of day in msec.
PUSHP RET
PUSHP TAC
PUSHP INERRS ;Remember number of errors at entry
MOVEI RET,INCHN
SHOWIT RET,
SETZM EOBYTS ;Start counting bytes
SKIPE RET,BINARY ;Binary?
JRST TRYBIN
; \ /
NORMTX: SKIPA TAC,[POINT 8,TOASCI(RET),35-4] ;ARPA FTP conversion
SAITXT: MOVE TAC,[POINT 8,TOASCS(RET),35-4] ;SAIL conversion
; \ /
TXTLP: CALL GETCHR ;Get byte from file
JUMPE RET,[MOVEI RET2,[ASCIZ/Text transfer complete. /]
JRST ERRCHK ]
TXTLP2: CAIN RET,15 ;Is it CR?
JRST[ SKIPN CRONLY ; Do we have to check these?
JRST .+1 ; No, flush it
CALL GETCHR ; Yes, get next thing
JUMPE RET,[MOVEI RET,15 ;Strange, file ends with CR, oh well.
CALL PUPPUT ;Send final return
RETURN ] ;and return.
CAIN RET,12 ; Is it a LF?
JRST[ MOVEI RET,15 ; Yes, flush it, and send CR
JRST .+1]
PUSHP RET ; No, sent CR, then other character
MOVEI RET,15
CALL PUPPUT
POPP RET
JRST TXTLP2 ]
SETZ RET2, ;Construct byte pointer into conversion table
ASHC RET,-2
ADD RET2,TAC ;Add point to appropriate conversion table
LDB RET,RET2 ;Fetch corresponding character
CALL PUPPUT
JRST TXTLP
; ---
;Note: Macro reverse 8 bit bytes within a word.
DEFINE CHMAP1(A0,A1,A2,A3,B0,B1,B2,B3,C0,C1,C2,C3,D0,D1,D2,D3) <
BYTE (8) A3,A2,A1,A0,B3,B2,B1,B0,C3,C2,C1,C0,D3,D2,D1,D0 >
;------------------------------------------------------------------------------
; Graphic Local Remote Name
;Normal:
; _ '30 '137 Underline
; ← '137 '30 Left arrow
; ≠ '33 '32 Not-equals
; <ALT> '175 '33 <ALT> (or <ESCAPE>)
;{ } '176 '175 Right brace
; ~ '32 '176 Tilde
;"SAIL":
; ≠ '33 '32 Not-equals
; <ALT> '175 '33 <ALT> (or <ESCAPE>)
;{ } '176 '175 Right brace
; ~ '32 '176 Tilde
;------------------------------------------------------------------------------
; NL ↓ α β ∧ ¬ ε π λ HT LF VT FF CR ∞ ∂
TOASCI: CHMAP1 0, 1, 2, 3, 4, 5, 6, 7, 10, 11, 12, 13, 14, 15, 16, 17
; ⊂ ⊃ ∩ ∪ ∀ ∃ ⊗ ↔ _ → ~ ≠ ≤ ≥ ≡ ∨
CHMAP1 20, 21, 22, 23, 24, 25, 26, 27,137, 31,176, 32, 34, 35, 36, 37
; SP ! " # $ % & ' ( ) * + , - . /
CHMAP1 40, 41, 42, 43, 44, 45, 46, 47, 50, 51, 52, 53, 54, 55, 56, 57
; 0 1 2 3 4 5 6 7 8 9 : ; < = > ?
CHMAP1 60, 61, 62, 63, 64, 65, 66, 67, 70, 71, 72, 73, 74, 75, 76, 77
; @ A B C D E F G H I J K L M N O
CHMAP1 100,101,102,103,104,105,106,107,110,111,112,113,114,115,116,117
; P Q R S T U V W X Y Z [ \ ] ↑ ←
CHMAP1 120,121,122,123,124,125,126,127,130,131,132,133,134,135,136, 30
; ` a b c d e f g h i j k l m n o
CHMAP1 140,141,142,143,144,145,146,147,150,151,152,153,154,155,156,157
; p q r s t u v w x y z { | ALT } DEL
CHMAP1 160,161,162,163,164,165,166,167,170,171,172,173,174, 33,175,177
;------------------------------------------------------------------------------
; NL ↓ α β ∧ ¬ ε π λ HT LF VT FF CR ∞ ∂
TOASCS: CHMAP1 0, 1, 2, 3, 4, 5, 6, 7, 10, 11, 12, 13, 14, 15, 16, 17
; ⊂ ⊃ ∩ ∪ ∀ ∃ ⊗ ↔ _ → ~ ≠ ≤ ≥ ≡ ∨
CHMAP1 20, 21, 22, 23, 24, 25, 26, 27, 30, 31,176, 32, 34, 35, 36, 37
; SP ! " # $ % & ' ( ) * + , - . /
CHMAP1 40, 41, 42, 43, 44, 45, 46, 47, 50, 51, 52, 53, 54, 55, 56, 57
; 0 1 2 3 4 5 6 7 8 9 : ; < = > ?
CHMAP1 60, 61, 62, 63, 64, 65, 66, 67, 70, 71, 72, 73, 74, 75, 76, 77
; @ A B C D E F G H I J K L M N O
CHMAP1 100,101,102,103,104,105,106,107,110,111,112,113,114,115,116,117
; P Q R S T U V W X Y Z [ \ ] ↑ ←
CHMAP1 120,121,122,123,124,125,126,127,130,131,132,133,134,135,136,137
; ` a b c d e f g h i j k l m n o
CHMAP1 140,141,142,143,144,145,146,147,150,151,152,153,154,155,156,157
; p q r s t u v w x y z { | ALT } DEL
CHMAP1 160,161,162,163,164,165,166,167,170,171,172,173,174, 33,175,177
;------------------------------------------------------------------------------
;Some kind of binary, see what kind
TRYBIN: PUSHP TAC ;Save an AC while searching
TRNN RET,777 ;Bytesize defined?
TRO RET,=8 ; No, pick default bytesize
MOVSI RET2,-TYPDSZ ;Setup to search for appropriate routine
TRYBI2: HLRZ TAC,TYPDIS(RET2) ;Get type of binary
CAME RET,TAC ;Match?
AOBJN RET2,TRYBI2 ; No, continue looking
POPP TAC ;Restore borrowed AC
JUMPGE RET2,[
MOVEI RET,RCILBY
MOVEI RET2,[ASCIZ/We don't support that mode of binary. /]
RETURN ]
HRRZ RET2,TYPDIS(RET2) ;Get address of routine
JRST (RET2) ;Do something about that type.
;Dispatch table for binary types for receive
TYPDIS: TYDSEN B,8,L8
TYDSEN B,32,L8 ;32 bit binary is same as 8 bit binary
TYDSEN B,36,L36 ;Funny Xerox 36 bit format
TYDSEN D,36,D36 ;PDP-10 dump mode
TYDSEN I,36,L72 ;Image mode
TYDSEN S,8,SAITXT ;SAIL
TYDSEN T,8,NORMTX ;Text
TYDSEN X,8,X8 ;Nothing special on recieve
TYDSEN X,32,X8
TYPDSZ←←.-TYPDIS ;Size of table in words.
;Left justified 8 bit binary
L8: MOVEI RET,8 ;Set byte size for transfer
DPB RET,[POINT 6,INHDR+1,11]
MOVEI RET2,17 ;Mask of bad bits to have on
L8A: CALL GETBYT ;Byte 1
JRST[ ; EOF or error.
L8B: MOVEI RET2,[ASCIZ/Left justified binary transfer complete. /]
JRST ERRCHK ]
TDNE RET2,@INHDR+1 ;Check the stray bits
JRST[ MOVEI RET,RCTRSP
MOVEI RET2,[ASCIZ/File is not left justified binary. /]
RETURN ]
CALL PUPPUT
CALL GETBYT ;Byte 2
JRST L8B ; EOF
CALL PUPPUT
CALL GETBYT ;Byte 3
JRST L8B ; EOF
CALL PUPPUT
CALL GETBYT ;Byte 4
JRST L8B ; EOF
CALL PUPPUT
JRST L8A ;Repeat for each word.
;Left justified 8 bit binary, ignore low order bits
X8: MOVEI RET,8 ;Set byte size for transfer
DPB RET,[POINT 6,INHDR+1,11]
X8A: CALL GETBYT ;Byte 1
JRST[ ; EOF or error.
X8B: MOVEI RET2,[ASCIZ/Left justified binary transfer complete. /]
JRST ERRCHK ]
CALL PUPPUT
CALL GETBYT ;Byte 2
JRST X8B ; EOF
CALL PUPPUT
CALL GETBYT ;Byte 3
JRST X8B ; EOF
CALL PUPPUT
CALL GETBYT ;Byte 4
JRST X8B ; EOF
CALL PUPPUT
JRST X8A ;Repeat for each word.
;36 bit PDP-10 Dump Mode (see DORCV for picture)
D36: MOVEI RET,=36 ;Set byte size to read file
DPB RET,[POINT 6,INHDR+1,11]
D36A: CALL GETBYT ;Pick up the first word
JRST[ MOVEI RET2,[ASCIZ/36 bit binary transfer complete. /]
JRST ERRCHK ]
MOVE RET2,RET ;Put it in a safer place
ROTC RET,8 ;Byte 1
CALL PUPPUT
ROTC RET,8 ;Byte 2
CALL PUPPUT
ROTC RET,8 ;Byte 3
CALL PUPPUT
ROTC RET,8 ;Byte 4
CALL PUPPUT
ROTC RET,4 ;Byte 5
ANDI RET,17 ;Just the low order 4 bits, please
CALL PUPPUT
JRST D36A ;Repeat
;36 bit PDP-10 Dump Mode (see DORCV for picture)
L36: MOVEI RET,=36 ;Set byte size to read file
DPB RET,[POINT 6,INHDR+1,11]
L36A: CALL GETBYT ;Pick up the first word
JRST[ MOVEI RET2,[ASCIZ/36 bit binary transfer complete. /]
JRST ERRCHK ]
MOVE RET2,RET ;Put it in a safer place
SETZ RET,
ROTC RET,4 ;Byte 1
CALL PUPPUT
ROTC RET,8 ;Byte 2
CALL PUPPUT
ROTC RET,8 ;Byte 3
CALL PUPPUT
ROTC RET,8 ;Byte 4
CALL PUPPUT
ROTC RET,8 ;Byte 5
CALL PUPPUT
JRST L36A ;Repeat
;Stream mode
L72: MOVEI RET,=36 ;Set byte size to read file
DPB RET,[POINT 6,INHDR+1,11]
L72A: CALL GETBYT ;Pick up the first word
JRST[
L72B: MOVEI RET2,[ASCIZ/Stream binary transfer complete. /]
JRST ERRCHK ]
MOVE RET2,RET ;Put it in a safer place
ROTC RET,8 ;Byte 1
CALL PUPPUT
ROTC RET,8 ;Byte 2
CALL PUPPUT
ROTC RET,8 ;Byte 3
CALL PUPPUT
ROTC RET,8 ;Byte 4
CALL PUPPUT
ROT RET2,4 ;Move four stray bits to low order byte
CALL GETBYT ;Pick up the second word
JRST[ MOVE RET,RET2 ;Ooops, none left
LSH RET,4
CALL PUPPUT
JRST L72B ]
ROTC RET,=32 ;Move low order 32 bits into RET2, RET will contain
;low order four bits of first word and high order
;four bits of second word, in that order (from left)
CALL PUPPUT ;Byte 5
ROTC RET,8 ;Byte 6
CALL PUPPUT
ROTC RET,8 ;Byte 7
CALL PUPPUT
ROTC RET,8 ;Byte 8
CALL PUPPUT
ROTC RET,8 ;Byte 9
CALL PUPPUT
JRST L72A ;Repeat
;Lastly, check for device errors.
;Jump here with completion string in RET2
ERRCHK: POPP RET ;Get number of errors before entering
POPP TAC ;Restore borrowed AC
CAME RET,INERRS ;Still the same?
JRST[ MOVEI RET,RCFDER ; No, we got a write error!
MOVEI RET2,[ASCIZ/Device error reading file. /]
RETURN ]
MSTIME RET, ;Calculate elaped time
SUB RET,(P)
FSC RET,233
FDVRI RET,(1000.0) ;Convert to seconds
MOVEM RET,(P) ;Save on stack
MOVE RET,EOBYTS
FSC RET,233+3 ;Multiply by 8 to get number of bits
FDVR RET,(P)
KAFIX RET,233000
MOVEM RET,BAUDRT
POPP <(P)> ;Flush stack
SETZ RET, ;No errors
RETURN
SUBREND DOSND
SUBR SNDLPL,IOBLK,OTHER ;Send property list from LOOKUP (also OPNPRN,CLSPRN,PUPQCK)
COMMENT ⊗ ---------------------------------------------------------------------
Calling Sequence:
PUSH P,[<address of file specification>] ;c.f. INBLK+1
PUSH P,[<subroutine for other properties or 0>]
PUSHJ P,SNDLPL
Returns:
Undefined
Description:
Invents and sends a property list for (presumably) the result of a LOOKUP
or ENTER.
Calls:
WRSIX,WRIOSP,WRFILN,WRINT,WRDATE,WRTIME
Side effects:
Clobbers RET
Sends [Here-Is-Property-List] followed by property list.
⊗;------------------------------------------------------------------------------
MOVE TAC,IOBLK ;Setup for easy reference
CALL OPNPRN ;Send "("
;Server-Name
CALL BEGPRP,<[TXSFIL]> ;Send "(Server-Filename "
SKIPN RET2,INFILE+3-INBLK-1(TAC) ;Is there a PPN?
JRST PPNOK ; Nothing to worry about
TRC RET2,770000 ;Watch out for neg. swap word count
TRCN RET2,770000
MOVE RET2,INFILE+4-INBLK-1(TAC)
PPNOK: EXCH RET2,INFILE+3-INBLK-1(TAC) ;Temp. set PPN for WRIOSP
MOVS RET,(TAC) ;Get device name (swapped, so we can use CAIN)
CAIN RET,'DSK' ;Is it the default?
JRST[ MOVEI RET,INFILE-INBLK-1(TAC) ;Yes, sigh... Suppress device
CALL WRFILN↑,RET,PUPQCK ; name so others don't lose.
JRST DEVHAK ]
CALL WRIOSP↑,TAC,PUPQCK ;Send our opinion of filename
DEVHAK: MOVEM RET2,INFILE+3-INBLK-1(TAC) ;Undo kludge
CALL CLSPRN ;Send ")"
;Device (if not DSK)
MOVE RET,(TAC) ;Get device name
CAMN RET,[SIXBIT/DSK/] ;Default?
JRST SKPDEV ; Yes, omit it according to convention
CALL BEGPRP,<[TXDEVI]> ;Send "(Device "
CALL WRSIX↑,(TAC),PUPQCK
CALL CLSPRN ;Send ")"
SKPDEV:
;Name-Body (i.e. file and extension)
SKIPN INFILE-INBLK-1(TAC) ;Is there a file name?
JRST SKPNMB ; No!!!
CALL BEGPRP,<[TXNAMB]> ;Send "(Name-Body "
CALL WRSIX↑,INFILE-INBLK-1(TAC),PUPQCK
;Send Filename part
MOVEI RET,"."
XCT PUPWOP
HLLZ RET,INFILE+1-INBLK-1(TAC) ;Get just extension
CALL WRSIX↑,RET,PUPQCK ;Send extension
CALL CLSPRN ;Send ")"
SKPNMB:
;Directory
SKIPN RET2,INFILE+3-INBLK-1(TAC) ;Is there a PPN
JRST SKPPPN ; No!!!
TRC RET2,770000 ;Watch out for neg. swap word count
TRCN RET2,770000
JRST[ SKIPN RET2,INFILE+4-INBLK-1(TAC) ;OK, try the other place
JRST SKPPPN ; Nothing there!
JRST .+1] ;Yeah, it got saved.
CALL BEGPRP,<[TXDIRE]> ;Send "(Directory "
HLLZ RET,RET2 ;Get project
CAMN RET,[SIXBIT/ 1/] ;Suppress project for [1,xxx]?
JRST NOPROJ ; Yes.
CALL WRSIX↑,RET,PUPQCK ;Output project
MOVEI RET,"-" ;Sop for TENEX
XCT PUPWOP
NOPROJ: HRLZ RET,RET2 ;Now, the programmer part
CALL WRSIX↑,RET,PUPQCK
CALL CLSPRN ;Send ")"
SKPPPN:
;Date/time written
LDB RET2,[POINT 3,INFILE+1-INBLK-1(TAC),20] ;Get high order date bits
LSH RET2,=12
LDB RET,[POINT 12,INFILE+2-INBLK-1(TAC),35] ;Plus the regular ones
ADD RET2,RET
JUMPE RET2,NOWDAT ;If zero, assume not known
CALL BEGPRP,<[TXWDAT]> ;Send "(Write-Date "
CALL WRDATE↑,RET2,PUPWOP ;Output date
MOVEI RET," "
XCT PUPWOP
LDB RET,[POINT 13,INFILE+2-INBLK-1,23] ;Time in minutes
IMULI RET,=60 ;Format for WRTIME
CALL WRTIME↑,RET,PUPWOP
CALL CLSPRN ;Send ")"
NOWDATE:
printx Do all callers of SNDLPL setup from UFD? If so, can send REFTIM.
;Size in words
SKIPN RET2,INFILE+3-INBLK-1(TAC) ;Is there a PPN or size?
JRST SKPSIZ ; No!!!
TRC RET2,770000 ;Is it a neg. swap word count?
TRCE RET2,770000
JRST SKPSIZ ; No, must be a PPN
CALL BEGPRP,<[TXSIZE]> ;Send "(Size "
MOVS RET,RET2
MOVN RET2,RET
printx SNDLPL should really be checking bytesize.
imuli ret2,5 ;*** Rough approximate for text
CALL WRINT↑,RET2,<[=10]>,PUPWOP ;Output size in words
;;; The following makes the other end choke.
;;; CALL WRASCZ↑,<[[ASCIZ/ words/]]>,PUPWOP ;Leave no doubt
CALL CLSPRN ;Send ")"
SKPSIZ: SKIPE OTHER ;Is there other stuff to send?
CALL @OTHER ; Yes, send it on down the line
CALL CLSPRN ;Send ")"
RETURN
;Send "("
↑OPNPRN:MOVEI RET,"("
XCT PUPWOP
POPJ P,
;Send ")"
↑CLSPRN:MOVEI RET,")"
XCT PUPWOP
POPJ P,
;Opcode to quote special characters in property list
↑PUPQCK:PUSHJ P,[CAIE RET,PQUOTE
CAIN RET,"("
JRST[
PUPQTR: PUSH P,RET
MOVEI RET,PQUOTE
PUSHJ P,PUPPUT
POP P,RET
JRST PUPPUT]
CAIN RET,")"
JRST PUPQTR
CAIN RET," " ;Suppress spaces in file names
POPJ P,
JRST PUPPUT ]
;Send three possible EOL-Conventions
↑SNDCR: HRRZ RET,ELNMTB+ELCR
SKIPA
↑SNDTRNS: HRRZ RET,ELNMTB+ELTRNS
SKIPA
↑SNDCRLF: HRRZ RET,ELNMTB+ELCRLF
PUSHP RET
CALL BEGPRP,<[TXEOLC]>
POPP RET
CALL WRASCZ,RET,PUPWOP
CALL CLSPRN
POPJ P,
SUBREND SNDLPL
SUBR SNDUPL,OPCODE,OTHER ;Send property list from user
COMMENT ⊗ ---------------------------------------------------------------------
Calling Sequence:
PUSH P,<input stream>
PUSH P,[<subroutine for other properties or 0>]
PUSHJ P,SNDUPL
Returns:
Undefined
Description:
Invents and sends a property list from user input and other variables.
Calls:
OPNPRN,CLSPRN,PUPQCK,BEGPRP,WRASCZ,WRINT
Side effects:
Clobbers RET,RET2
Sends property list.
⊗;------------------------------------------------------------------------------
CALL OPNPRN ;Send "("
;Server-Name
CALL BEGPRP,<[TXSFIL]> ;Send "(Server-Filename "
URDLP: XCT OPCODE ;Get something from user
JUMPE RET,URDEND
CAIN RET,15 ;CR?
XCT OPCODE ; Yes, get LF
CAIE RET,12 ;LF?
CAIN RET,175 ;or ALT?
JRST URDEND ; Yes, terminate
XCT PUPQCK ;Check for special characters and transmit
JRST URDLP ;Repeat until something ends it all.
; ---
URDEND: CALL CLSPRN ;Send ")"
; \ /
SKIPE OTHER ;Anything special to do?
CALL @OTHER ; Yes, send user name, etc.
CALL CLSPRN ;Send ")"
RETURN
SUBREND SNDUPL
SUBR SNDUNM ;Send user name and other information
COMMENT ⊗ ---------------------------------------------------------------------
Calling Sequence:
PUSHJ P,SNDUNM
Returns:
Undefined
Description:
Sends user name, password, account, type and bytesize.
CAUTION: Not intended to be called in server mode.
Calls:
BEGPRP,WRASCZ↑,PUPWOP,OPNPRN,CLSPRN
Side effects:
Clobbers RET and no others
⊗;------------------------------------------------------------------------------
;Set Type
CALL BEGPRP,<[TXTYPE]>
SKIPN RET,U.TYPE
MOVEI RET,TYPE.T
CAIN RET,TYPE.X ;Special hack for Type X
MOVEI RET,TYPE.B
HRRZ RET,TNAMTB(RET) ;Get name from symbol
CALL WRASCZ,RET,PUPWOP
CALL CLSPRN
;Set Byte size
CALL BEGPRP,<[TXBYTE]>
SKIPN RET,U.BYTE
MOVEI RET,8
CALL WRINT↑,RET,<[=10]>,PUPWOP
CALL CLSPRN
;Set the rest
FOR @' I IN (EOLC,UNAM,UPSW,UACT,DIRE)
< SKIPN U.'I
JRST SK'I
CALL BEGPRP,<[TX'I]>
CALL WRASCZ,U.'I,PUPWOP
CALL CLSPRN
SK'I:>;FOR I
RETURN
SUBREND SNDUNM
SUBR BEGPRP,STRING ;Begin a property list
COMMENT ⊗ ---------------------------------------------------------------------
Calling Sequence:
PUSH P,[<address of property name string>]
PUSHJ P,BEGPRP
Returns:
Undefined
Description:
Sends "(" followed by string and a space.
Calls:
WRASCZ↑,PUPWOP
Side effects:
Clobbers RET and no others
⊗;------------------------------------------------------------------------------
MOVEI RET,"("
XCT PUPWOP
CALL WRASCZ↑,STRING,PUPWOP
MOVEI RET," "
XCT PUPWOP
RETURN
SUBREND BEGPRP
SUBR RDPLST,OPCODE ;Read a property list
COMMENT ⊗ ---------------------------------------------------------------------
Calling Sequence:
PUSH P,<stream opcode>
PUSHJ P,RDPLST
Returns:
RET: Pointer to property list (or zero if error)
RET2: XWD error message,terminating character.
Description:
Attempts to read property list. Returns zero if error. No error message if
property list is empty.
Algorithm:
Keeps calling RDPLST until ')' is found.
Calls:
RDPROP
Side effects:
Clobbers TAC,NAMBUF
⊗;------------------------------------------------------------------------------
LOCALS{PLST}
XCT OPCODE ;Get first character
CAIE RET,"("
JRST[ MOVE RET2,RET ;Save terminator
SETZ RET,
JRST DONE ]
LOOP: CALL RDPROP,OPCODE ;Get a property
JUMPLE RET,[ ; None, check termination
CAIN RET2,")" ;
JRST DONE
TLNN RET2,-1 ;Fill in error message, if none given
HRLI RET2,[ASCIZ/Rcv'ed bad property list./]
PUSHP RET2 ;Save error message over release
CALL RLPLST,PLST ;Flush current list
POPP RET2
SETZ RET,
RETURN ]
MOVE RET2,PLST ;Add new property to list
CALL PFCONS
MOVEM RET,PLST
JRST LOOP
; ---
DONE: MOVE RET,PLST ;Return property list
RETURN
SUBREND RDPLST
SUBR RDPROP,OPCODE ;Read a property list element
COMMENT ⊗ ---------------------------------------------------------------------
Calling Sequence:
PUSH P,<stream opcode>
PUSHJ P,RDPROP
Returns:
RET: CONS pair or
0: Does not begin with "(", prob. end of property list
-1: Other error
RET2: terminating character if RET=0
NAMBUF: name
Description:
Attempts to read a property list element.
Algorithm:
Reads a name and looks it up in the property name list.
If it's not there, it complains, but eat the value part anyway and returns -1.
Reads value, and executes routine for each type, almost all of which simply
save the string.
Calls:
RDNAME,SYBSRH,COPSTR,UPSTR,PFCONS
WARNMSG
Side effects:
Clobbers TAC,NAMBUF
⊗;------------------------------------------------------------------------------
LOCALS{PNAME}
RETRY: XCT OPCODE ;Get first character
CAIE RET,"(" ;Is it the beginning of a property list?
JRST[ MOVE RET2,RET ;Save character
SETZ RET, ;Return NIL
RETURN ]
CALL RDNAME,OPCODE ;Read name of property
CAIE RET2," " ;Normal termination?
JRST[ PUSHJ P,WARNMSG
ERRARG TXT,TXFHSN
ERRARG TXT,[ASCIZ/bad character in property name: /]
ERRARG CHR,RET2
ERRARG CRLF,0
0
SETOM PNAME
JRST FLUSH ]
CALL SYBSRH,<[NAMBUF]>,<[PNAMTB]>
;Look it up in the list of known properties
MOVEM RET,PNAME
JUMPE RET,[ ;We don't know about this one.
PUSHJ P,WARNMSG
ERRARG TXT,TXFHSN ;Foreign host sent...
ERRARG TXT,[ASCIZ/unknown property: /]
ERRARG TXT,NAMBUF
ERRARG CRLF,0
0
JRST FLUSH ]
FLUSH: MOVNI RET2,NAMLEN ;Limit size of string
MOVE TAC,[POINT 7,NAMBUF]
LOOP: XCT OPCODE ;Get character from stream
CAIN RET,")" ;End of property?
JRST GOT2ND ; Yes
SKIPE RET ;EOD?
CAIN RET,"(" ;Probable bug?
JRST[ PUSHJ P,WARNMSG
ERRARG TXT,TXFHSN ;Foreign host sent...
ERRARG TXT,[ASCIZ/malformed property list./]
ERRARG CRLF,0
0
SETOM PNAME ;If there was any doubt...
MOVE RET,[XWD [ASCIZ/malformed property list./],")"]
JRST GOT2ND ] ;Normal termination.
CAIN RET,PQUOTE ;Quote something?
XCT OPCODE ; Yes, quote *anything*
IDPB RET,TAC ;Stuff in character
AOJL RET2,LOOP ;Count characters
; \ /
ADD TAC,[7B5] ;Backup the string pointer
JRST LOOP ;And just keep changing the last character
; ---
GOT2ND: MOVE RET2,RET ;Save terminating character
SETZ RET, ;Do null filling
NULLLP: IDPB RET,TAC
TLNE TAC,760000 ;Done yet?
JRST NULLLP ; No, more to go
SKIPGE RET,PNAME ;Is this anything we know about?
RETURN ; No, discard it! (Message already printed)
JUMPE RET,RETRY ;For now, try again on unknown properties
XCT PNAMOP(RET) ;Convert NAMBUF to something meaningful.
MOVE RET2,RET ;Make a LISP cell
MOVE RET,PNAME
CALL PFCONS
RETURN ;And return it!
;Default, save text
↑PXDFLT:CALL COPSTR,<[NAMBUF]>
POPJ P,
;Byte-size: <decimal number>
↑PXBYTE:PUSHP <[POINT 7,NAMBUF]> ;Setup stream pointing into NAMBUF
MOVSI RET,(<ILDB RET,>)
HRRI RET,(P)
CALL RDINT↑,<[=10]>,RET
POPP <(P)> ;Flush string pointer for stream
POPJ P,
;Passwords
↑PXUPSW:
↑PXCPSW:CALL CVSIX,<[NAMBUF]> ;Convert the password to SIXBIT
SETZM NAMBUF ;That ought to obliterate it.
SETZM NAMBUF+1
JUMPE RET,NOPSW ;Don't hash zero!
PXCPS2: TRNN RET,77 ;Right justify it
JRST[ LSH RET,-6
JRST PXCPS2 ]
IFE FTXINF,<
CALL HASHER,RET ;Mangle it to discourange password hacking
>;IFE FTXINF
NOPSW: PUSHP RET
CALL FSGET,<[1]> ;Sigh...
POPP <(RET)>
POPJ P,
;Type and EOL conventions
↑PXEOLC:SKIPA RET2,[ELNMTB]
↑PXTYPE:MOVEI RET2,TNAMTB
PUSHP RET2
CALL UPSTR,<[NAMBUF]>
POPP RET
CALL SYBSRH,<[NAMBUF]>,RET
SKIPE RET
POPJ P,
PUSHJ P,WARNMSG
ERRARG TXT,TXFHSN ;Foreign host sent...
ERRARG TXT,[ASCIZ/unknown value: /]
ERRARG TXT,NAMBUF
ERRARG CRLF,0
0
POP P,(P) ;Flush return address
SETO RET,
MOVSI RET2,[ASCIZ/unknown value for property./]
RETURN ;Give up.
;Common preamble to error message
↑TXFHSN:ASCIZ /Foreign host sent /
;Define table for handling properties
DEFINE X '(SYM,NAME,SIZE) <
IFDEF PX'SYM,< PUSHJ P,PX'SYM >
IFNDEF PX'SYM,< PUSHJ P,PXDFLT >
>;DEFINE X
PNAMOP: PUSHJ P,DRYROT ;0: "Can't happen"
XLIST
PNAMES
LIST
SUBREND RDPROP
SUBR RDNAME,OPCODE ;Read a name
COMMENT ⊗ ---------------------------------------------------------------------
Calling Sequence:
PUSH P,<stream opcode>
PUSHJ P,RDNAME
Returns:
RET: number of characters in name
RET2: terminating character
NAMBUF: name
Description:
Reads name from specified stream and constructs a name in NAMBUF.
Algorithm:
Stops on anything that isn't a letter, digit, or minus.
Calls:
Nothing
Side effects:
Clobbers TAC
Puts name in NAMBUF
⊗;------------------------------------------------------------------------------
MOVNI RET2,NAMLEN ;Limit size of string
MOVE TAC,[POINT 7,NAMBUF]
LOOP: XCT OPCODE ;Get character from stream
CAIL RET,"A" ;Letter?
CAILE RET,"Z"
JRST[ CAIL RET,"a" ;No, lower case letter?
CAILE RET,"z"
JRST[ CAIL RET,"0" ;No, digit?
CAILE RET,"9"
JRST SPCCHK ; No, check specials
IDPB RET,TAC ;Stuff in character
AOJL RET2,LOOP ;Count characters
JRST TOOBIG ] ;Semi-infinite name!!!
SUBI RET,"a"-"A" ;Convert to upper case
IDPB RET,TAC ;Stuff in character
AOJL RET2,LOOP ;Count characters
JRST TOOBIG ] ;Semi-infinite name!!!
ADDCHR: IDPB RET,TAC ;Stuff in character
AOJL RET2,LOOP ;Count characters
; \ /
TOOBIG: ADD TAC,[7B5] ;Backup the string pointer
JRST LOOP ;And just keep changing the last character
; ---
SPCCHK: CAIN RET,"-" ;Is it TENEX funny letter?
JRST ADDCHR ; Yeah, sigh...
PUSHP RET ;Save terminator
PUSHP RET2 ;Save count
SETZ RET, ;Do null filling
NULLLP: IDPB RET,TAC
TLNE TAC,760000 ;Done yet?
JRST NULLLP ; No, more to go
POPP RET ;Restore those thing, in reverse order (really)
POPP RET2
ADDI RET,NAMLEN ;Gives characer count in RET
RETURN ;We're done.
SUBREND RDNAME
SUBR RDSTRB,BRKTAB,OPCODE ;Read a string according to break table.
COMMENT ⊗ ---------------------------------------------------------------------
Calling Sequence:
PUSH P,<break table>
PUSH P,<stream opcode>
PUSHJ P,RDSTRB
Returns:
RET: number of characters in string
RET2: terminating character
NAMBUF: string
Description:
Reads name from specified stream and constructs string in NAMBUF.
Calls:
Nothing
Side effects:
Puts name in NAMBUF
⊗;------------------------------------------------------------------------------
PUSHP TAC
PUSHP TAC2
MOVNI TAC2,NAMLEN ;Limit size of string
MOVE TAC,[POINT 7,NAMBUF]
LOOP: XCT OPCODE ;Get character from stream
PUSHP RET ;Save character
IDIVI RET,=36 ;Select word in break table
ADD RET,BRKTAB
HRLI RET,(<POINT 1,0,0>)
ROT RET2,-6
SUB RET,RET2 ;Finish making byte pointer
POPP RET2 ;Restore character
LDB RET,RET ;Get bit for character
JUMPN RET,STREND ;If on, end of string
JUMPE RET2,LOOP ;Flush nulls which don't terminate
IDPB RET2,TAC ;Stuff in character
AOJL TAC2,LOOP ;Count characters
; \ /
TOOBIG: ADD TAC,[7B5] ;Backup the string pointer
JRST LOOP ;And just keep changing the last character
; ---
STREND: PUSHP RET2 ;Save terminator
PUSHP TAC2 ;Save count
SETZ RET, ;Do null filling
NULLLP: IDPB RET,TAC
TLNE TAC,760000 ;Done yet?
JRST NULLLP ; No, more to go
POPP RET ;Restore those thing, in reverse order (really)
POPP RET2
ADDI RET,NAMLEN ;Gives characer count in RET
POPP TAC2 ;Restore saved ACs
POPP TAC
RETURN ;We're done.
SUBREND RDSTRB
SUBR RDEHST,OPCODE ;Read Ethernet host name
COMMENT ⊗ ---------------------------------------------------------------------
Calling Sequence:
PUSH P,<stream opcode>
PUSHJ P,RDEHST
Returns:
RET: Host address or zero
Description:
If numeric, reads host number. Otherwise, asks gateway for host address
from host number
Calls:
RDINT
Side effects:
Clobbers TAC
Clobbers connection in PUPCHN
Sets NOPRMT if terminated by ";".
⊗;------------------------------------------------------------------------------
CALL RDSTRB,<[LINBR2]>,OPCODE ;Read entire line
PUSHP RET ;Save byte count
CAIN RET2,15 ;CR
XCT CMDOP ; Yes, read ubiquitous LF
cain ret2,";" ;Kludge to avoid extra prompt.
setom noprmt ; **Sigh** There ought to be a better way
LDB RET,[POINT 7,NAMBUF,6] ;Get first character
JUMPE RET,[RETURN] ;If none, forget it
CAIL RET,"0" ;Is it a digit?
CAILE RET,"9"
JRST NOTNUM ; No, not a numeric host name
PUSHP <[POINT 7,NAMBUF]> ;Yes, read an octal host number
MOVEI TAC,(P) ;Construct a stream to read host number
HRLI TAC,(<ILDB RET,>)
pushp 0
CALL RDINT,<[8]>,TAC
move ret2,0
popp 0
CAIE RET2,"#" ;Possibly more to go?
JRST NONET
MOVE RET2,(P) ;Peek at next character
JUMPE RET2,NONET ;If none, forget it
LSH RET,8 ;Move into network position
PUSHP RET ;Save network number
pushp 0
CALL RDINT,<[8]>,TAC
move ret2,0
popp 0
POPP RET2 ;Get back network number
ADD RET,RET2 ;Merge with host number
NONET: POPP <(P)> ;Flush string pointer from stack
RETURN
;Host name given
NOTNUM: SETSTS PUPCHN,15 ;Use packet mode to get host name
MTAPE PUPCHN,MSCBLK ;Exchange packets with misc. server using
; GENSYM local socket number.
SKIPE MSCSTS
PUSHJ P,DRYROT
SETZM PKTBUF ;Clear out old header, so WAITS fills this
MOVE RET,[XWD PKTBUF,PKTBUF+1] ;stuff in.
BLT RET,PKTBFD
MOVEI RET,MNAMLK ;Misc. Service, Name Lookup
DPB RET,PKTTYP
MSCDST::SETZ RET, ;Broadcast packet (normally local net)
DPB RET,PKTDHN
POPP RET ;Get length
ADDI RET,PUPOVH ;Add in overhead
DPB RET,PKTLEN
MOVE TAC,[POINT 8,PKTBFD] ;Data area
MOVE RET2,[POINT 7,NAMBUF] ;Source
L1: ILDB RET,RET2 ;Copy string until null is seen
IDPB RET,TAC
JUMPN RET,L1 ;We know NAMBUF is smaller than PKTBUF
MOVEI TAC,=15 ;Number of times to retry
L2: LDB RET,PKTLEN ;Get size of packet in bytes
ADDI RET,2+2+3 ;Plus Ethernet header plus rounding
ASH RET,-2 ;From bytes to words.
MOVN RET,RET
MOVS RET,RET
HRRI RET,PKTBUF-1 ;Make an IOWD
SETZ RET2,
OUT PUPCHN,RET ;Try sending packet
JRST L3 ; Sent, it claims
PUSHJ P,WARNMSG
ERRARG TXT,[ASCIZ/Ethernet error while trying to get host number from name./]
ERRARG CRLF,0
0
JRST TRYNUM
; ---
;Wait for reply from Misc. Services. Don't clobber TAC
L3: MOVEI RET,PUPSIP
MTAPE PUPCHN,RET ;Skip if input present
JRST[ SETZ RET2, ;Nope, wait a jiffie and try again
SLEEP RET2,
MTAPE PUPCHN,RET ;Win this time?
SKIPA ; No
JRST .+1 ; Yes!
SETZ RET2, ;Nope, wait a jiffie and try again
SLEEP RET2,
MTAPE PUPCHN,RET ;Win this time?
SKIPA ; No
JRST .+1 ; Yes!
MOVEI RET2,1 ;Try a second
SLEEP RET2,
MTAPE PUPCHN,RET ;How about now?
SOJG TAC,L2 ; No, try sending request again.
JUMPG TAC,.+1 ; Yes, we finally got a response
PUSHJ P,WARNMSG
ERRARG TXT,[
ASCIZ/No Ethernet response to request for host number from name./]
ERRARG CRLF,0
0
JRST TRYNUM ] ;Let them eat cake
; \ /
;We got a packet, see what it is.
IN PUPCHN,[IOWD PKTWSZ,PKTBUF↔ 0] ;Try reading the packet
JRST L4 ; Packet OK
PUSHJ P,WARNMSG
ERRARG TXT,[ASCIZ/Ethernet error while trying to get host number from name./]
ERRARG CRLF,0
0
JRST TRYNUM
; ---
;Packet has good data. Let's see what we got.
L4: LDB RET,PKTTYP ;Get PUP type
CAIN RET,MLKERR ;Directory look error?
JRST[ CALL WRASCZ↑,<[[ASCIZ/Host name error: /]]>,ERMSOP
LDB RET2,PKTLEN ;Get size of packet in bytes
SUBI RET2,PUPOVH
MOVE TAC,[POINT 8,PKTBFD] ;Pointer to data area
L4A: ILDB RET,TAC ;Print message we got
XCT ERMSOP
SOJG RET2,L4A
CALL WRASCZ↑,<[[ASCIZ/
/]]>,ERMSOP
SETZ RET, ;Error return.
JRST DONE ]
CAIN RET,MNAMRS ;Response?
JRST[ LDB RET,[POINT 16,PKTBFD,15] ; Yes, get host number
JRST DONE ] ; and we're done!
PUSHJ P,WARNMSG
ERRARG TXT,[ASCIZ/Unexpected response to host number request: '/]
ERRARG OCT,RET
ERRARG CRLF,0
0
; JRST TRYNUM
; \ /
;Misc. services isn't feeling very good today. Let the user take a guess at
; the host number.
TRYNUM: MOVE RET,OPCODE
CAME RET,[PUSHJ P,CMDGET]
JRST GIVEUP
CALL WRASCZ↑,<[[ASCIZ/You may try giving a host number: /]]>,ERMSOP
pushp 0
call rdint↑,<[=8]>,opcode
exch 0,(p)
popp ret2
; \ /
;Flush any connect we might have had to Misc. Services. Don't clobber RET, it
;contains the host address.
DONE: CLOSE PUPCHN, ;Flush any connection that still might be active
;; SETSTS PUPCHN,0 ;Go back to BSP mode.
releas pupchn, ;*** CLOSE doesn't clear PUPLNK
pushp pupihd+1
pushp pupohd+1
open pupchn,pupblk
pushj p,dryrot
popp pupohd+1
popp pupihd+1
RETURN ;We're done.
SUBREND RDEHST
SUBR GTHNAM,NUM ;Get Ethernet host name from number
COMMENT ⊗ ---------------------------------------------------------------------
Calling Sequence:
PUSH P,<host number>
PUSHJ P,RDEHST
Returns:
RET: SIXBIT/Host name/
Description:
Calls MRC's host stuff to get long and short name of host. Long name is
return in HNAME
Calls:
RDINT
Side effects:
Clobbers HNAME
Clobbers I/O channel 0
Expands core, then contracts to current JOBFF
⊗;------------------------------------------------------------------------------
LOCALS {SIXHST}
setz ret,
PUSHACS ;Thank you very much, Mark Crispin.
PUSHJ P,MAPHST
MOVE 0,NUM
IOR 0,[NW%SU] ;set network field in host name for HSTNUM
PUSHJ P,HSTNUM ;get host name from number
JFCL ;failed, but accept dotted host nbr it returns
; JRST[ SETZB 0,HNAME
; JRST LOST ]
PUSHP RET
PUSHP RET2
HRLI RET,(<POINT 7,0>) ;Make a string
SRCHLP: ILDB RET2,RET ;Get a character from string
JUMPN RET2,SRCHLP ;More left to go
HRRZ RET2,-1(P)
SUBI RET2,(RET)
MOVN RET2,RET2 ;Length of string - 1
CAIL RET2,HNAMSZ ;Paranoid programming dept.
MOVEI RET2,HNAMSZ-1
MOVEI RET,HNAME ;Copy host name somewhere permanent
HRL RET,-1(P) ; as we can't use FS due to MRC's
BLT RET,HNAME(RET2) ; method of mapping in host table
POPP RET2
POPP RET
PUSHJ P,SETANM ;Get SIXBIT form of data
LOST: MOVEM 0,SIXHST ;Save it while restoring ACs
POPACS
MOVE RET,SIXHST
PUSHJ P,UNMHST
return
HSTSIX←←1
.INSERT NETWRK.FAI[S,NET] ;I sure would like to avoid this!
SUBREND GTHNAM
SUBR RLPLST,PLST ;Release space from Property List
COMMENT ⊗ ---------------------------------------------------------------------
Calling Sequence:
PUSH P,<property list>
PUSHJ P,RLPLST
Returns:
Undefined
Description:
Recovers storage from property list
Algorithm:
Goes down the property list calls PFUNCS for each pair and FSREL on
any property pointing into free storage.
Calls:
FSREL,PFUNCS
Side effects:
Affects free storage and LISPish free list.
Clobbers property list
⊗;------------------------------------------------------------------------------
SKIPN RET,PLST ;Get property list, if any
RETURN ; None, done.
; \ /
L1: PUSHP RET ;Save address of this cell
HLRZ RET,(RET) ;Get property name/value pair
PUSHP RET ;Save it on the stack as well
HLRZ RET,@(P) ;Get property name
cain ret,p.byte ;Does it have a numeric value?
jrst l3 ; Yes, forget it!
CAML RET,FSBEG↑ ;Could it be in F.S.?
CAML RET,JOBREL↑
JRST L2 ; No, don't collect it
CALL FSREL↑,RET ;Release name
; \ /
L2: HRRZ RET,@(P) ;Get property value
CAMGE RET,FSBEG↑ ;Could it be in F.S.
JRST L3 ; No, don't collect it
CALL FSREL↑,RET ;Release name
; \ /
L3: POPP RET ;Restore pair
CALL PFUNCS ;Release it
HRRZ RET,@(P) ;Get pointer to next thing
EXCH RET,(P) ;Swap with node to release
CALL PFUNCS ;Release this node
POPP RET ;Get back next node
JUMPN RET,L1 ;Repeat until end of list
; \ /
DONE: RETURN
SUBREND RLPLST
SUBR PLGET,PLST,PNAMCD ;Search property list
COMMENT ⊗ ---------------------------------------------------------------------
Calling Sequence:
PUSH P,<property list>
PUSH P,[<property number>]
PUSHJ P,PLGET
Returns:
RET: Value of property (or zero if not found)
Description:
Searches property list for given property
Calls:
Nothing
Side effects:
Clobbers RET2
⊗;------------------------------------------------------------------------------
PUSHP TAC
SKIPN RET,PLST ;Get property list, if any
JRST DONE ; None, done.
LOOP: HLRZ RET2,(RET) ;Get first property
HLRZ TAC,(RET2) ;Get name of property
CAMN TAC,PNAMCD ;Is this it?
JRST[ HRRZ RET,(RET2) ; Yes, get property and we're done
JRST DONE ]
HRRZ RET,(RET) ;No, get next thing on property list
JUMPN RET,LOOP ;Repeat for each property on property list
DONE: POPP TAC
RETURN
SUBREND PLGET
SUBR PLSTNM,PLST,IOBLK ;Derive file name from property list
COMMENT ⊗ ---------------------------------------------------------------------
Calling Sequence:
PUSH P,<property list>
PUSH P,<address of I/O specification> ;c.f. INBLK+1
PUSHJ P,PLSTNM
Returns:
RET: Reply code, which is zero if successful
RET2: Error message string if RET is non-zero
Description:
Looks at the property list to try to come up with a SAIL style file name.
Algorithm:
Collects relevant properties into local variables.
Decides what the defaults are.
Calls RDIOSP to fill the rest in.
Calls:
RDSIX,RDPPN,RDIOSP
Side effects:
Clobbers RET2,TAC,TAC2
⊗;------------------------------------------------------------------------------
LOCALS{SRVNAM,NAMBOD,DEVNAM} ;Server-Filename, Name-Body, Device-Name
LOCALS{USRNAM,CONNAM,DIRNAM} ;User-Name, Connect-Name, Directory
PL←TAC2
SKIPN PL,PLST ;Get property list, if any
JRST[ MOVEI RET,RCMFPL
MOVEI RET2,[ASCIZ/Missing or malformed property list./]
RETURN ]
PLLOOP: HLRZ TAC,(PL) ;Get first element of property list
HRRE RET,(TAC) ;Get value
HLRZ RET2,(TAC) ;Get thing to dispatch on
CAIG RET2,PLXSIZ ;Address check (for paranoid reasons)
JUMPG RET2,[
XCT PLXTAB(RET2) ;Do something about this property
JRST .+1 ] ;Rest is normal
PHACK←←.PLEVEL ;Current position of stack
HRRZ PL,(PL) ;Get next thing off property list
JUMPN PL,PLLOOP ;Repeat for each thing on property list
; \ /
MOVE TAC,IOBLK
PRINTX Device defaulting doesn't work due to bug in RDIOSP
SKIPN RET,DEVNAM ;Get device name, if any
JRST[ MOVSI RET,'DSK' ; Use default
JRST DEFDEV]
CALL CVSIX,RET ;Convert string to straight SIXBIT
LDB RET2,RET2 ;Get terminating character
JUMPE RET2,DEFDEV
CAIE RET,":" ;Terminated normally?
JRST[ MOVEI RET,RCILDV
MOVEI RET2,[ASCIZ/Illegal character in device name./]
RETURN ]
DEFDEV: MOVEM RET,(TAC)
SKIPN RET,SRVNAM ;Server-Filename takes precedence
MOVE RET,NAMBOD ;Second choice is Name-Body
JUMPE RET,[ ;Watch for case of no file.
SETZM INFILE-INBLK-1(TAC) ;No file given
RETURN ]
setz ret2, ;Save old alias
dskppn ret2,
pushp ret2 ;Save it on the stack
SKIPN RET2,DIRNAM ;Find best
SKIPE RET2,CONNAM
JRST GOTPPN
SKIPN RET2,USRNAM
MOVEI RET2,[ASCIZ/100,100/] ;Our default non-user (sigh...)
GOTPPN: PUSHP RET
CALL CVPPN,RET2
MOVE RET2,RET
POPP RET
tlne ret2,-1 ;Kludge to cause better error message if no
trnn ret2,-1 ;PPN is given. Sigh...
JRST[ MOVEM RET2,OUTFIL+3
SETZM OUTFIL
SETZM OUTFIL+1
MOVEI RET2,[ASCIZ/Illegal user or directory name./]
SKIPE RET2,DIRNAM ;Find best
JRST[ MOVEI RET,RCILDR
JRST FINIS2 ]
SKIPE RET2,CONNAM
JRST[ MOVEI RET,RCILAC
JRST FINIS2 ]
SKIPN RET2,USRNAM
JRST[ MOVEI RET,RCILUS
JRST FINIS2 ]
movei ret,rcilus ;Who knows...
JRST FINIS2 ]
dskppn ret2, ;Set new default directory (stupid RDIOSP)
HRLI RET,(<POINT 7,0>) ;Make a string pointer
PUSHP RET
MOVEI RET,(P) ;Make a stream instruction
HRLI RET,(<ILDB RET,>)
CALL RDIOSP↑,IOBLK,RET,<[0]> ;Read the filename
JRST[
BADIOS: SKIPN SRVNAM
SKIPA RET,[RCILNB]
MOVEI RET,RCILSF
MOVEI RET2,[ASCIZ/Illegal file name./]
JRST FINIS1 ]
JUMPN RET,BADIOS
FINIS1: POPP <(P)> ;Flush string pointer
FINIS2: exch ret2,(p) ;Restore alias
dskppn ret2,
popp ret2
RETURN ;And we're done
.PLEVEL←←PHACK ;Make sure stack is correct when these are computed!
PQCNAM←←<MOVEM RET,CONNAM> ;CONNECT-NAME
PQDEVI←←<MOVEM RET,DEVNAM> ;DEVICE
PQDIRE←←<MOVEM RET,DIRNAM> ;DIRECTORY
PQNAMB←←<MOVEM RET,NAMBOD> ;NAME-BODY
PQSFIL←←<MOVEM RET,SRVNAM> ;SERVER-FILENAME
PQUNAM←←<MOVEM RET,USRNAM> ;USER-NAME
;Define table for handling properties
DEFINE X '(SYM,NAME,SIZE) <
IFDEF PQ'SYM,<
IFG PQ'SYM-777777,< PQ'SYM > ;Single instruction case
IFLE PQ'SYM-777777,< PUSHJ P,PQ'SYM> ;Otherwise, a subroutine
>;IFDEF PQ'SYM
IFNDEF PQ'SYM,< JFCL >
>;DEFINE X
PLXTAB: PUSHJ P,DRYROT ;0: "Can't happen"
XLIST
PNAMES
LIST
PLXSIZ←←.-PLXTAB
SUBREND PLSTNM
SUBR PLSTSL,PLST ;Construct a search list from property list
COMMENT ⊗ ---------------------------------------------------------------------
Calling Sequence:
PUSH P,<property list>
PUSHJ P,PLSTNM
Returns:
Success:
RET: Search list
RET2: SIXBIT device name
Failure:
RET: -reply code
RET2: Error message string if RET is non-zero
Description:
Looks at the property list to try to come up with a SAIL style file name.
Algorithm:
Collects relevant properties into local variables.
Decides what the defaults are.
Calls:
STRSL
Side effects:
Clobbers RET2,TAC,TAC2
⊗;------------------------------------------------------------------------------
LOCALS{SRVNAM,NAMBOD,DEVNAM} ;Server-Filename, Name-Body, Device-Name
LOCALS{USRNAM,CONNAM,DIRNAM} ;User-Name, Connect-Name, Directory
LOCALS{PPNSTR} ;PPN from Server-Filename
PL←TAC2
SKIPN PL,PLST ;Get property list, if any
JRST[ SETO RET, ; None, done.
RETURN ]
PLLOOP: HLRZ TAC,(PL) ;Get first element of property list
HRRE RET,(TAC) ;Get value
HLRZ RET2,(TAC) ;Get thing to dispatch on
CAIG RET2,PLXSIZ ;Address check (for paranoid reasons)
JUMPG RET2,[
XCT PLXTAB(RET2) ;Do something about this property
JRST .+1 ] ;Rest is normal
PHACK←←.PLEVEL ;Current position of stack
HRRZ PL,(PL) ;Get next thing off property list
JUMPN PL,PLLOOP ;Repeat for each thing on property list
; \ /
;Find out what device we have. Bless the device name. Save it in SIXBIT
;in DEVNAM
SKIPN RET,DEVNAM ;Get device name, if any
JRST[ SKIPN RET,SRVNAM ;Get full name
JRST[
SETDSK: MOVSI RET,'DSK' ; Use default
JRST GOTDEV ]
CALL CVSIX,RET ;Try for device name
LDB RET2,RET2 ;Get terminator
CAIE RET2,":"
JRST SETDSK ; It isn't a device name
JRST GOTDEV ]
CALL CVSIX,RET ;Convert string to straight SIXBIT
LDB RET2,RET2 ;Get break character
JUMPE RET2,GOTDEV ;If null, then done
CAIE RET2,":" ;Otherwise, must be ":"
JRST[ MOVNI RET,RCILDV
CAIE RET2,"?"
CAIN RET2,"*" ;Wild card device?
SKIPA RET2,[[
ASCIZ/Device must be fully specified. No '*' or '?'/]]
MOVEI RET2,[ASCIZ/Illegal character in device name/]
RETURN ]
GOTDEV: MOVEM RET,DEVNAM ;Save SIXBIT form back in DEVNAM
; \ /
;Check for Server-Filename. If one is found, then break it up into filename
;and PPN parts.
SKIPN RET,SRVNAM ;Server-Filename takes precedence. Use it
; over defaults
JRST NOSRNM ; None. Hope we have enough to work with
PUSHP NAMBOD ;Save this in case we goof
MOVEM RET,NAMBOD ;Force filename
HRLI RET,(<POINT 7,0>) ;Make it into a string pointer
SRNMLP: ILDB RET2,RET
SRNML1: CAIN RET2,":" ;Did we find a device?
JRST[ MOVEM RET,NAMBOD ;Yes, tentatively set filename again!
ILDB RET2,RET ;Get next character
JUMPE RET2,[ ;Null!! We were wrong about
MOVE RET2,(P) ;name body! Get old copy
MOVEM RET2,NAMBOD ;and put it back.
JRST SRNMDN ]
JRST SRNML1 ]
CAIN RET2,"[" ;PPN found?
JRST[ MOVEM RET,PPNSTR ;Yes, save it way
ILDB RET2,RET
JUMPE RET2,[ ;Yes, but it doesn't look right
MOVNI RET,RCILSF
MOVEI RET2,[ASCIZ/Bad PPN in filename./]
RETURN ]
JRST SRNMDN ]
JUMPN RET2,SRNMLP
SRNMDN: POPP <(P)>
NOSRNM:
; \ /
;Figure out what to use for directory. Don't worry about protection issues
;at this point. They aren't handled in this routine anyway.
SKIPN RET2,PPNSTR ;Find best
SKIPE RET2,DIRNAM
JRST GOTPPN
SKIPN RET2,CONNAM
SKIPE RET2,USRNAM
JRST GOTPPN
;Nothing was specified which might be a PPN. Invent one.
SKIPE SRVRSW
SKIPA RET2,[SIXBIT/100100/] ;Our default non-user (sigh...)
DSKPPN RET2,
PUSHP RET2
CALL FSGET,<[SNSIZE]> ;Synthesize the search node, it's easier
POPP RET2 ;than converting result of DSKPPN to a
MOVEM RET2,SNONS(RET) ;string.
SETCAM RET2,SNOFFS(RET)
MOVSI RET2,'UFD'
MOVEM RET2,SNONS+1(RET)
SETCAM RET2,SNOFFS+1(RET)
HLLZS SNOFFS+1(RET)
SETZM SNNEXT(RET) ;Nothing follows, yet.
JRST GOTPP2
; ---
GOTPPN: CALL STRSL,RET2,<[XWD 200000,0]>
;Make a search list out of this
JUMPL RET,[RETURN] ;If error, bail out
JUMPE RET,[ ;If we failed to make a search list, complain
MOVNI RET,RCFNF ;We don't know who dunnit.
MOVEI RET2,[ASCIZ/Impossible name for directory./]
RETURN]
GOTPP2: PUSHP RET ;Save directory search list on stack
CALL STRSL,NAMBOD,<[0]> ;Now, read file name
JUMPL RET,[
NMFAIL: EXCH RET,(P) ;Lost.
PUSHP RET2 ;Save error message
CALL RLSL,RET ;Release search list
POPP RET2 ;Restore error message
MOVE RET,(P) ;*** POP P,RET leaves stack wrong for RETURN
RETURN ] ;*** macro!
JUMPE RET,[ ;If we failed to make a search list, complain
MOVNI RET,RCFNF ;We don't know who dunnit.
MOVEI RET2,[ASCIZ/Impossible name for file./]
JRST NMFAIL ]
MOVE RET2,(P) ;Get PPN search list
SPPNLP: HRLM RET,SNNEXT(RET2) ;Point PPN entry at file search list
HRRZ RET2,SNNEXT(RET2) ;Advance to next PPN
JUMPN RET2,SPPNLP ;Repeat for each search list entry
POPP RET ;Return PPN search list
MOVE RET2,DEVNAM ;And SIXBIT device name
RETURN ;We finally done!
.PLEVEL←←PHACK ;Make sure stack is correct when these are computed!
PQCNAM←←<MOVEM RET,CONNAM> ;CONNECT-NAME
PQDEVI←←<MOVEM RET,DEVNAM> ;DEVICE
PQDIRE←←<MOVEM RET,DIRNAM> ;DIRECTORY
PQNAMB←←<MOVEM RET,NAMBOD> ;NAME-BODY
PQSFIL←←<MOVEM RET,SRVNAM> ;SERVER-FILENAME
PQUNAM←←<MOVEM RET,USRNAM> ;USER-NAME
;Define table for handling properties
DEFINE X '(SYM,NAME,SIZE) <
IFDEF PQ'SYM,<
IFG PQ'SYM-777777,< PQ'SYM > ;Single instruction case
IFLE PQ'SYM-777777,< PUSHJ P,PQ'SYM> ;Otherwise, a subroutine
>;IFDEF PQ'SYM
IFNDEF PQ'SYM,< JFCL >
>;DEFINE X
PLXTAB: PUSHJ P,DRYROT ;0: "Can't happen"
XLIST
PNAMES
LIST
PLXSIZ←←.-PLXTAB
SUBREND PLSTSL
SUBR STRSL,SRCSTR,UFDSW ;Construct search sublist from string.
COMMENT ⊗ ---------------------------------------------------------------------
Calling Sequence:
PUSH P,<string>
PUSH P,[400000,,0 if UFD, otherwise zero.]
PUSHJ P,STRSL
Returns:
Success:
RET: Search list (first level)
Failure:
RET: 0
Description:
Looks at a string to try to come up with a mask pair for a SAIL style file
name/extension pair. Returns a search list consisting of all such possible
mask pairs.
Algorithm:
Converts to SIXBIT and copies into SNBUF. Constructs a mask pair node (SN)
when it find the right number of characters to make a file name. If it
encounters a '*', it is considered to match any number of any SIXBIT character
including the '.' for an extension, but excluding the '[' meaning PPN or ','
meaning next file (unless in PPN mode). If reading PPN, ',' is allowed instead
of '.', but only three characters are permitted in the first and second halves
of the PPN (as opposed to six and three, respectively for regular filename), and
the PPN is right justified instead of left justified within the half words. A
'>' is also acceptable in lieu of ',' and causes halves to be swapped in order
to be mildly compatable with IFS conventions. '?' matched one of any SIXBIT
character excluding '.' or their like.
When it determines that a file name is not possible (too many letters, etc.)
it returns whatever it was able to make, if anything.
When a '*' is encountered, it matches any number of characters as mentioned
above. This is achieved by saving the parsing state, and recursively calling
itself for each additional character until it is no longer possible to form a
file name. At that point, it returns whatever it was able to construct.
Calls:
FSGET, self.
Side effects:
Clobbers RET2,TAC,TAC2
⊗;------------------------------------------------------------------------------
ACCUMULATORS{S,P1,P2,CNT,DAT,FL}
PUSHP S ;Save ACs we'll need
PUSHP P1
PUSHP P2
PUSHP CNT
PUSHP DAT
PUSHP FL
MOVE S,SRCSTR ;Initial pointer to string
TLNN S,-1 ;Is it a string pointer yet?
HRLI S,(<POINT 7,0>) ; Now it is.
MOVEI DAT,SNBUF ;Use fixed place to buffer search node
SETZM SNNEXT(DAT) ;Nothing exists yet
MOVEI P1,SNONS(DAT) ;Setup initial byte pointers
HRLI P1,(<POINT 6,0>)
MOVEI P2,SNOFFS(DAT)
HRLI P2,(<POINT 6,0>)
MOVEI CNT,6 ;Yes
HLLZS 1(P1) ;Make sure right half of extension is ignored
HLLZS 1(P2)
SKIPE FL,UFDSW ;Is there an extension to be supplied?
JRST[ MOVSI RET,'UFD' ;No, it's a UFD
HLLZM RET,SNONS+1(DAT) ;Set it
SETCAM RET,SNOFFS+1(DAT)
HLLZS SNOFFS+1(DAT) ;Ignore right half
MOVEI CNT,3 ;Split first word into two halves
JRST .+1]
PUSHJ P,LOOP ;Now, construct a file name
HRRZ RET,SNNEXT(DAT) ;Return whatever we succeeded in making
POPP FL ;Restore borrowed ACs
POPP DAT
POPP CNT
POPP P2
POPP P1
POPP S
RETURN
; ---
LOOP: MOVE RET2,S ;Save pointer to string
ILDB RET,S ;Get a character from source string
CAIL RET,"a" ;Lower case?
CAILE RET,"z"
JRST[ CAIL RET," " ;Is it SIXBIT?
CAIL RET,"[" ;... and not special
JRST ENDSTR ; No, presume end of string
CAIN RET,"?" ;Does it match anything?
JRST[ SETZ RET, ;Yes...
IDPB RET,P1
IDPB RET,P2
JRST BNDCHK ] ;Watch for boundary
CAIN RET,"#" ;Does it match a "digit"?
JRST[ MOVEI RET,'0' ;Yes, these bits must be on
IDPB RET,P1
MOVEI RET,¬'0'&¬17 ;These bits must be off
IDPB RET,P2
JRST BNDCHK ]
CAIN RET,"@" ;Does it match a "letter"?
JRST[ MOVEI RET,'A'&¬37 ;Yes, these bits must be on
IDPB RET,P1
MOVEI RET,¬'A'&¬37 ;These bits must be off
IDPB RET,P2
JRST BNDCHK ]
CAIN RET,">" ;Funny PPN character?
JRST[ TLNN FL,200000 ; PPN?
JRST BACKUP ; NO! Barf.
TLO FL,100000 ; Yes, set funny PPN mode
JRST GOTPRJ ] ; Start programmer (actually project)
CAIE RET,"-"
CAIN RET,","
JRST[ TLNE FL,200000 ;PPN?
JRST GOTPRJ ; Yes, assume project completed.
CAIN RET,"-"
JRST NORMAL ;If not in a PPN, consider normal SIXBIT
; (not a fantastic idea, but...)
JRST ENDSTR ] ;Comma which separates files.
CAIN RET,"." ;Does this begin extension?
JRST[
GOTPRJ: PUSHJ P,BEGEXT ;Yes, do something about it
JRST BACKUP ; Failed
JRST LOOP ] ;Look at next thing
CAIN RET,"*" ;Wild card?
JRST STAR ; Yes, this one is special!
SUBI RET," "-' ' ;Convert to SIXBIT
JRST NORMAL ]
; \ /
SUBI RET,"a"-'A' ;Convert to SIXBIT
NORMAL: IDPB RET,P1 ;These bits should be on
SETCM RET,RET
IDPB RET,P2 ;These bits should be off
; \ /
BNDCHK: SOJG CNT,LOOP ;Go back for more
; \ /
;This thing is full. If next thing isn't a terminator, we've lost.
MOVE RET2,S ;Save S in case of "*"
ILDB RET,S ;Get next thing
CAIL RET,"a" ;Is it lower case?
CAILE RET,"z"
JRST[ CAIL RET," " ;No, Is it SIXBIT?
CAIL RET,"["
JRST ENDSTR ; No, we win.
CAIE RET,"-"
CAIN RET,","
JRST[ TLNE FL,200000 ;PPN?
JRST GOTPJ2 ; Yes, assume project completed.
CAIN RET,"-"
JRST BACKUP ;If not in a PPN, consider normal SIXBIT
; (not a fantastic idea, but...)
JRST ENDSTR ] ;Comma which separates files.
CAIN RET,"." ;Is it a dot?
JRST[
GOTPJ2: PUSHJ P,BEGEXT ;Yes, maybe we can do an extension
JRST BACKUP ; Nope. We've lost
JRST LOOP ] ;Yes, three more characters allowed
CAIN RET,"*" ;Is it wild?
JRST[ MOVE S,RET2 ;Yes, it could become an extension
PUSHJ P,BEGEXT ;Try it
JRST BACKUP ; Lost.
JRST LOOP ] ;OK, we're back in business
JRST BACKUP ] ;Give up.
BACKUP: SETZ RET, ;We failed.
POPJ P, ;Go back up a level
; ---
;We have something we do matches on. Fill out rest of word and take successful
;return.
ENDSTR: PUSHJ P,BEGEXT ;Is there an extension left?
JFCL ; Don't worry if we don't
JUMPLE CNT,ENDST2 ;Jump if already filled out
SETZ RET, ;Finish file name and/or extension
SETO RET2,
; \ /
ENDST1: IDPB RET,P1
IDPB RET2,P2
SOJG CNT,ENDST1
; \ /
ENDST2: CALL FSGET↑,<[SNSIZE]> ;Get a node for this file
MOVE RET2,RET ;Copy fixed node
HRLI RET2,(DAT)
BLT RET2,SNSIZE-1(RET)
MOVEM RET,SNNEXT(DAT) ;Point any new nodes at this one (by virtue of
;above BLT this will happen).
TLNN FL,200000 ;PPN mode?
POPJ P, ; No, take successful return now.
TLNN FL,100000 ;Is this a funny PPN?
JRST[ HRRZ RET2,SNONS(RET) ;No, check for missing programmer
JUMPN RET2,REGPPN ; There is something there
SETCM RET2,SNOFFS(RET) ;Second check for wild cards
TRNE RET2,-1
JRST REGPPN
MOVS RET2,RET2 ;Programmer ← project, project ← 1
HRLI RET2,' 1'
SETCAM RET2,SNOFFS(RET)
MOVS RET2,SNONS(RET)
HRLI RET2,' 1'
MOVEM RET2,SNONS(RET)
JRST REGPPN]
MOVSS SNONS(RET) ;Swap project and programmer
MOVSS SNOFFS(RET)
REGPPN: HLRZ RET2,SNONS(RET) ;Fixup project
PUSHJ P,PPNFIX
HRLM RET2,SNONS(RET)
HRRZ RET2,SNONS(RET) ;Fixup programmer
PUSHJ P,PPNFIX
HRRM RET2,SNONS(RET)
HLRO RET2,SNOFFS(RET) ;And the complement
PUSHJ P,PPNFXC
HRLM RET2,SNOFFS(RET)
HRRO RET2,SNOFFS(RET)
PUSHJ P,PPNFXC
HRRM RET2,SNOFFS(RET)
POPJ P, ;Now we can take successful return.
;Right adjust
PPNFIX: SKIPE RET2 ;Return immediately if empty
PPNFX2: TRNE RET2,77 ;Is right justified yet?
POPJ P, ; Yes, done
LSH RET2,-6 ;Shift right one character
JRST PPNFX2 ;And try again.
; ---
;Right adjust complemented
PPNFXC: SETCA RET2,
PUSHJ P,PPNFIX
SETCA RET2,
POPJ P,
; ---
;We have a wild card.
STAR: ILDB RET,S ;Get next character
MOVE S,RET2 ;Backup to '*'
CAIL RET," "
CAIL RET,"["
JRST STARZZ ;'*' which matches reset of name
CAIN RET,"." ;'*' which matches up to extension
JRST STARXX ; Don't recur
CAIE RET,"," ;'*' in PPN, or end of file name
CAIN RET,"-"
JRST[ TLNE FL,200000 ;Which special case
JRST STARXX ; The PPN flavor
CAIN RET,"," ;Which of the others
JRST STARZZ ; A comma between files.
JRST STARLP] ;The normal '-' case (sigh...)
STARLP: PUSH P,S ;Save current state
PUSH P,P1
;;; PUSH P,P2 ;(P2 = P2 + SNONS - SNOFFS)
PUSH P,FL
PUSH P,CNT
PUSH P,SNNEXT(DAT) ;Remember current state of this
IBP S ;Skip over '*'
PUSHJ P,LOOP ;Now, do rest of string
POP P,RET ;Get back old state to see if changed
POP P,CNT
POP P,FL
;;; POP P,P2 ;Recomputed below
POP P,P1
POP P,S
MOVE P2,P1
ADDI P2,SNONS-SNOFFS
CAMN RET,SNNEXT(DAT) ;Did what we do help at all?
JRST STARYY ; No, one more thing to try
SETZ RET2,
IDPB RET2,P1 ;Accept anything
IDPB RET2,P2
SOJG CNT,STARLP ;And try again
STARYY: PUSHJ P,BEGEXT ;'*' cause also match '.'
JRST BACKUP ; But, no, it didn't
JRST STARLP ;Yes, so try another iteration
;Fill rest of first field with any character coding
STARXX: TLNE FL,400000 ;Doing extension?
JRST BACKUP ; Ooops, next character can't match
STARZ1: SETZ RET2,
STARX1: IDPB RET2,P1 ;Accept anything
IDPB RET2,P2
SOJG CNT,STARX1 ;And try again
IBP S ;Skip over '*'
JRST LOOP ;Go handle next character
;Fill rest of both fields with any character coding
STARZZ: TLON FL,400000 ;Doing second field yet?
ADDI CNT,3 ; No, fill it too
JRST STARZ1 ;Now, do the filling
;Begin extension, if this is still permitted.
BEGEXT: JUMPL FL,[POPJ P,] ;Non-skip return if already in extension, or it
;is disallowed
JUMPLE CNT,BEGEX2 ;Don't fill with zeros if already full
SETZ RET,
SETO RET2,
; \ /
BEGEX1: IDPB RET,P1 ;Fill out file name
IDPB RET2,P2
SOJG CNT,BEGEX1
; \ /
BEGEX2: MOVEI CNT,3 ;Count number of characters remaining
TLO FL,400000 ;Extension (or PPN) being processed
AOS (P) ;Skip return means success
POPJ P,
SUBREND STRSL
SUBR MAPSL,SRCLST,READOP,FN ;Apply FN on files matching search list
COMMENT ⊗ ---------------------------------------------------------------------
Calling Sequence:
PUSH P,<search list>
PUSH P,[<opcode to read from OPCODE> ;Skips on success.
PUSH P,[<address of subroutine to execute for each file>]
PUSHJ P,MAPSL
Returns:
Undefined
Description:
Algorithm:
Calls:
@FN
@READOP
Side effects:
Affects free storage
Clobbers RET,RET2, and UFDBUF
⊗;------------------------------------------------------------------------------
SN←TAC2+1 ;Search list
SKIPN SRCLST ;Any matches possible?
RETURN ;No, forget it.
PUSHP SN
PUSHP TAC ;Save ACs while looking for matches
PUSHP TAC2
LOOP: MOVSI RET2,-FDESIZ
LOOP1: XCT READOP ;Read word from file directory
JRST DONE ; End of file directory
MOVEM RET,UFDBUF(RET2) ;Stuff it into temporary buffer
AOBJN RET2,LOOP1 ;Repeat for entry for single file
SKIPN RET,UFDBUF ;Setup things for loop, check for empty
JRST LOOP ; Deleted file or empty entry
SETCM TAC,UFDBUF
MOVE RET2,UFDBUF+1
SETCM TAC2,UFDBUF+1
MOVE SN,SRCLST ;Get first entry in search list
LOOP2: TDNN RET,SNOFFS(SN) ;Is file name OK?
TDNE TAC,SNONS(SN)
JRST TRYNXT
TDNN RET2,SNOFFS+1(SN) ;Is file name OK?
TDNE TAC2,SNONS+1(SN)
JRST TRYNXT
MOVE RET,SN ;Preserve search node
POPP TAC2 ;Restore ACs to those of caller
POPP TAC
POPP SN
CALL @FN,RET ;Call user function with search node
PUSHP SN ;Save ACs again
PUSHP TAC
PUSHP TAC2
JRST LOOP ;Go to next file in list. We don't care,
; for now at least, if w would get more than
; one match
TRYNXT: HRRZ SN,SNNEXT(SN) ;Try next entry in search list
JUMPN SN,LOOP2 ;If there an entry...
JRST LOOP ;Otherwise, try next file
DONE: POPP TAC2 ;Restore ACs to those of caller
POPP TAC
POPP SN
RETURN
SUBREND MAPSL
SUBR RLSL,SRCLST ;Release space from Search List
COMMENT ⊗ ---------------------------------------------------------------------
Calling Sequence:
PUSH P,<search list>
PUSHJ P,RLSL
Returns:
Undefined
Description:
Recovers storage from search list
Algorithm:
Goes down the search list calling itself for any sublist, and then FSREL
to remove the node itself.
Calls:
FSREL,self
Side effects:
Affects free storage
Clobbers RET,RET2, and search list
⊗;------------------------------------------------------------------------------
PUSHP TAC
SKIPN TAC,SRCLST ;Get property list, if any
RETURN ; None, done.
; \ /
LOOP: HLRZ RET,(TAC) ;Get sublist, if any
JUMPE RET,NOSUBL ; None
PUSHP TAC ;Save pointer to list
CALL RLSL,RET ;Release sublist
POPP TAC
NOSUBL: MOVE RET,TAC ;Remember thing we're about to flush
HRRZ TAC,(TAC) ;Get pointer to next thing in list
CALL FSREL,RET ;Release this node
JUMPN TAC,LOOP ;Repeat as long as any more nodes exist
DONE: RETURN
SUBREND RLSL
SUBR CHKPRO,PLIST,IOSPEC,ACCTYP ;Check file protection
COMMENT ⊗ ---------------------------------------------------------------------
Calling Sequence:
PUSH P,<property list for user name>
PUSH P,<I/O specificaton>
PUSH P,<type of access (see ACCCHK)>
PUSHJ P,CHKPRO
Returns:
RET: 0 or reply code if protection fails.
RET2: Error string, if RET is non-zero
Description:
Check SAIL's elaborate protection scheme (may ___ rot it!)
Algorithm:
[Go read FTPSER.FAI[S,NET] if you really want to know.]
Calls:
ACCCHK, GRPCHK
Side effects:
May set UPPN,OLDPSW,PRIVS,PSWD
Uses PROCHN for its own purposes.
⊗;------------------------------------------------------------------------------
CALL USRCHK ;Check user name
CALL UFDCHK ;Check UFD protection
MOVE RET2,ACCTYP ;Just reading the directory?
CAIN RET,A.STAT
JRST[ RELEASE PROCHN, ; Yes, we're done. Clean up a bit first
RETURN ] ; then leave.
CALL FILCHK ;Check file itself
RETURN
.PLEVEL←←.PLEVEL+1 ;All that follows is called by PUSHJ, but
;might return thru the main return address.
;Check for existence and for change in user name/password
USRCHK: CALL PLGET,PLIST,<[P.UNAM]> ;Get user name
JUMPE RET,SKPPCK ;If none, forget this nonsense
CALL CVPPN,RET ;Convert it to a SAIL PPN
EXCH RET,UPPN
CAME RET,UPPN ;Same as the last time thru here?
JRST CHKUSR ; No, check user name and password
IFN FTXINF,<
CALL HASHER,RET ;If we haven't mangled it yet, do it now.
>;IFN FTXINF
CAMN RET,OLDPSW ;Same as the last one?
JRST SKPPCK ; Yes, don't bother checking again
CHKUSR: SETZM PASSOK ;Password no longer valid
SETZM PRIVS
SKIPN UPPN ;Was a user name supplied?
JRST SKPPCK ; No, don't check password.
MOVSI RET,'DSK' ;All user name's live on the disk
MOVEM RET,PROBLK+1
OPEN PROCHN,PROBLK ;Get ready to read user's UFD
JRST[ PUSHJ P,WARNMSG
ERRARG TXT,[ASCIZ/Can't INIT DSK!/]
ERRARG CRLF,0
0
JRST SKPPCK ] ;Plod onward!
MOVE RET,UPPN
CALL GETUFD
JRST[ RELEASE PROCHN, ;Saves FS in system.
MOVEI RET,RCILUS
MOVEI RET2,[ASCIZ/No such user. /]
RETURN ]
IFE FTXINF,<
MOVSI RET,INFPRV ;We need to get the password
PRVIOR RET,
>;IFE FTXINF
MTAPE PROCHN,PRVMTA ;Read special stuff (at least for priv bits)
JRST SKPPCK ; Can't. Forget about giving owner access.
IFE FTXINF,<
MOVE RET,PASWD
SETZM PASWD
jfcl ;Place to invent a password for debugging
JUMPE RET,SKPPCK ;If no password, we can get owner access
CALL HASHER,RET ;Make life harder for password hackers
MOVEM RET,PASWD ;Put it back for a while
CALL PLGET,PLIST,<[P.UPSW]> ;Get password
MOVE RET2,PASWD
CAME RET2,(RET) ;Do they hash to the same thing?
JRST SKPPCK ; No, can't possibly be right
SETOM PASSOK ;We took it.
MOVEM RET2,OLDPSW ;Save it for later checking.
>;IFE FTXINF
IFN FTXINF,<
SETZM PASWD ;Just in case...
CALL PLGET,PLIST,<[P.UPSW]> ;Get password again
JUMPE RET,[SETZM PASSOK ; No longer valid
JRST SKPPCK ]
MOVE RET,(RET) ;Get (maybe) mangled password from f.s. block
MOVEM RET,PASMTA+3
MTAPE PROCHN,PASMTA ;At M. Frost's request.
JRST[ SETZM PASMTA+3
JRST SKPPCK ]
SETZM PASMTA+3
SETOM PASSOK
CALL HASHER,RET ;At least make it more challenging...
MOVEM RET,OLDPSW ;Put it back for a while
>;IFN FTXINF
MOVE RET,PRIVWD ;Copy privileges to permanent place.
MOVEM RET,PRIVS
;We've decided whether we are a specific user or not. Now, decide on the access
;of the UFD we want.
SKPPCK: RELEASE PROCHN, ;Flush what was there before
IFE FTXINF,<
MOVSI RET,INFPRV ;No longer need to be special
PRVACM RET,
>;IFE FTXINF
POPJ P,
;Check UFD for access.
UFDCHK: MOVE TAC,IOSPEC
PUSHP <2(TAC)> ;Don't let system mess with buffer headers
SETZM 2(TAC)
OPEN PROCHN,-1(TAC) ;Get at device user wants.
SKIPA RET,[RCILDV] ;Save indication of failure
SETZ RET, ;or success
POPP <2(TAC)> ;Restore buffer pointers for user
JUMPN RET,[ ;We lost.
MOVEI RET2,[ASCIZ/Illegal or inaccessable device: /]
RETURN ]
SKIPN RET,INFILE+3-INBLK-1(TAC) ;Get PPN, if any
MOVE RET,UPPN ; Shouldn't happen, but just in case...
PUSHJ P,GETUFD ;LOOKUP UFD
JRST[ MOVEI RET2,[ASCIZ/No such directory: /]
MOVEI RET,RCILDR ;Passable error code. We don't
RELEASE PROCHN, ; know at this point where it came
RETURN ] ; from.
MOVE RET2,PROFIL ;PPN
MOVE TAC,ACCTYP
PUSHJ P,GRPCHK ;Decide if we have owner to UFD
MOVE RET,PROFIL+2 ;Setup protection
PUSHJ P,ACCCHK ;Check for access at all
JRST[ MOVEI RET,RCILDR ;We don't really know where the
; directory came from, so error
; code might be tecnically wrong.
MOVEI RET2,[ASCIZ/Directory is protected: /]
RELEAS PROCHN,
RETURN ]
SETZ RET, ;In case this is all we need
POPJ P,
;Check protection of file itself. Assumed to have already called UFDCHK and PROCHN
;is still open.
FILCHK: MOVEI RET,PROCHN ;Check to make sure channel is still open.
DEVCHR RET,
SKIPN RET
PUSHJ P,DRYROT ;It's pretty hard to recover here.
MOVE TAC,IOSPEC
MOVSI RET,INFILE-INBLK-1(TAC) ;Point at file name part
HRRI RET,PROFIL ;Copy file name
BLT RET,PROFIL+3
LOOKUP PROCHN,PROFIL ;See if file exists
JRST[ SETZ RET, ; It doesn't. But don't worry about it.
POPJ P, ] ; caller will find out soon enough.
MOVE RET2,INFILE+3-INBLK-1(TAC) ;PPN
MOVE TAC,ACCTYP
PUSHJ P,GRPCHK ;Decide if we have owner to UFD
MOVE RET,PROFIL+2 ;Setup protection
PUSHJ P,ACCCHK ;Check for access at all
JRST[ MOVEI RET,RCPROF ;Protection failure
MOVEI RET2,[ASCIZ/File is protected: /]
RELEAS PROCHN,
RETURN ]
RELEASE PROCHN, ;We're done with this for now.
SETZ RET, ;We succeeded.
POPJ P,
;LOOKUP UFD and skip if successful.
GETUFD: MOVEM RET,PROFIL ;Setup LOOKUP block
MOVSI RET,'UFD'
MOVEM RET,PROFIL+1
MOVE RET,MFDFIL
MOVEM RET,PROFIL+3
LOOKUP PROCHN,PROFIL ;Try it
POPJ P, ; Failed.
AOS (P)
POPJ P,
SUBREND CHKPRO
.INSERT ACCCHK.FAI[S,NET] ;Ah, you found it!
SUBR CHKDEV,DEVNAM ;Check file protection
COMMENT ⊗ ---------------------------------------------------------------------
Calling Sequence:
PUSH P,[<sixbit device name>]
PUSHJ P,CHKDEV
Returns:
RET: <status bits for OPEN>
or -<reply code> if failed
RET2: <error message if failed>
Description:
Make sure it is a device we can cope with.
CAUTION: If paper tape, don't touch byte pointers in buffered mode!
Binary mode will have to do something special for paper tape.
Side effects:
Clobbers RET2
⊗;------------------------------------------------------------------------------
MOVE RET2,DEVNAM ;Get name of device
DEVCHR RET2, ;And from it, its characteristics
JUMPE RET2,[MOVNI RET,RCILDV ;If no such device, return
MOVEI RET2,[ASCIZ/No such device: /]
RETURN ]
TLNN RET2,40 ;Is device available?
JRST[ MOVNI RET,RCFBSY
MOVEI RET2,[ASCIZ/Device in use or unavailable: /]
RETURN ]
TLNE RET2,100000 ;UDP?
JRST[ TLNN RET2,200000 ;Is it new style?
JRST[ MOVNI RET,RCFBSY
MOVEI RET2,[ASCIZ/User disk pack in use privately: /]
RETURN ]
MOVE RET,DEVNAM ;Has in been assigned by something?
DEVUSE RET,
TLNN RET,50000
JRST[ MOVNI RET,RCTFSF
MOVEI RET2,[ASCIZ/Someone must ASSIGN user disk pack for you: /]
RETURN ] ;Fail, don't stop job, on errors
ISDSK: MOVEI RET,200
RETURN ]
TLNE RET2,200000 ;DSK? (Must be after we heck for UDP)
JRST ISDSK ; Yes, this is easy
TLNE RET2,600 ;PTR/PTP/PLT?
JRST[ MOVEI RET,41 ; Yes, use image mode
RETURN ] ; CALLER HAD BETTER NOT SET BYTE SIZE!
MOVNI RET,RCILDV ;Something we don't know about
MOVEI RET2,[ASCIZ/Illegal device for FTP: /]
RETURN
SUBREND CHKDEV
SUBR FNDUSR,KEYSTR ;Find user name (check legality)
COMMENT ⊗ ---------------------------------------------------------------------
Calling Sequence:
PUSH P,[<string pointer>]
PUSHJ P,FNDUSR
Returns:
RET: new string containing user name else -error code.
RET2: error string if failed
Description:
Searches FACT.TXT and FORWRD.TXT to see if the user name is legal.
Side effects:
Clobbers RET2
Upper casifies name if local destination
⊗;------------------------------------------------------------------------------
LOCALS{PPN,BEGMAT,FILES}
LOCALS{NOTFST}
ACCUMULATORS{TEM,CNT,KP,NP}
PUSHP TEM ;Save some ACs to use
PUSHP CNT
PUSHP KP
PUSHP NP
SETZM INBLK ;Make sure status is kosher
MOVSI RET,'DSK'
MOVEM RET,INBLK+1
MOVEI RET,[SIXBIT/FORWRD/↔SIXBIT/TXT/↔0↔SIXBIT/MAISYS/ ;must be first
SIXBIT/FACT/↔SIXBIT/TXT/↔0↔SIXBIT/SPLSYS/
0]
MOVEM RET,FILES
CALL INOPEN ;Open DSK:
CALL DRYROT
L00: HRLZ RET,FILES
HRRI RET,INFILE
BLT RET,INFILE+3
LOOKUP INCHN,INFILE ;Try to read FACT.TXT[SPL,SYS]
JRST[ CALL WARNMSG
ERRARG TXT,[ASCIZ/Lookup failed on FACT or FORWRD file!/]
ERRARG CRLF,0
0
MOVNI RET,RCTFSF
MOVEI RET2,[ASCIZ/User name file is busy, try again later./]
JRST DONE ]
PUSHJ P,GTEDIR ;skip over any E directory
MOVE KP,KEYSTR ;Make sure we have a string pointer
TLNN KP,-1
HRLI KP,(<POINT 7,0>)
MOVEM KP,KEYSTR
ILDB RET,KP ;Check for #file...
CAIN RET,"#"
JRST FILEOK ; Let MAIL figure this one out.
; \ /
INDCHK: ILDB RET,KP ;Get another character (don't tolerate
; a leading "@"
CAIE RET,"@" ;Host name?
CAIN RET,"%"
JRST CHKHST ; Yes, check it for MAIL
JUMPN RET,INDCHK ;Look some more
CALL UPSTR,KEYSTR ;Convert to upper case if we're really
;going to search for anything.
; \ /
L01: MOVE NP,[POINT 7,NAMBUF] ;Start saving a new entry
MOVEI CNT,NAMLEN-2 ;For paranoia's sake
L02: MOVE KP,KEYSTR ;Start at beginning of name
MOVEM NP,BEGMAT ;Remember beginning of match
L03: PUSHJ P,GETCHR ;Get character from fact file
JUMPE RET,L09 ;Jump if EOF
SOSL CNT ;Stuff into buffer, if there is space left
IDPB RET,NP
CAIL RET,"a" ;Force upper case
CAILE RET,"z"
CAIA
SUBI RET,"a"-"A"
ILDB RET2,KP ;Get character from search string
CAMN RET,RET2 ;Does it match?
JRST L03 ; Yes, go back for more
CAIN RET,15 ;CR?
PUSHJ P,GETCHR ; Yes, get LF
JUMPN RET2,[ ;Jump if we have mismatch
L04: CAIN RET,12 ;LF?
JRST L01 ; Yes, start new line
SKIPN NOTFST ;is this first file (\F)?
JRST L05 ;yes, don't look after tab
CAIE RET,11 ;Start new name yet?
CAIN RET,40
JRST L02 ; Yes, got delimiter
L05: PUSHJ P,GETCHR ;Search for break
JUMPE RET,L09 ; Funny place to get EOF
SOSL CNT ;Stuff into buffer
IDPB RET,NP
JRST L04 ] ;And try again
MOVE TEM,[POINT 7,NAMBUF] ;Find first tab
TABSLP: ILDB RET,TEM
CAIE RET,11
JUMPN RET,TABSLP
SETZ RET, ;Get ready to replace <tab> with <null> for
;COPSTR
CAMN TEM,NP ;Did we match a programmer name?
JRST[ DPB RET,TEM ;yes, replace <tab> with <null>
CALL COPSTR,<[NAMBUF]> ; to make a string out of programmer name
EXCH RET,PPN ;clear any previous match
SKIPG RET ;skip if previous match
JRST NOMAT1
CALL FSREL,RET ;free the FS of previus match
NOMAT1: MOVE RET,PPN ;return winning string
JRST DONEOK ]
MOVE RET2,BEGMAT ;Get beginning of match
CAME RET2,[POINT 7,NAMBUF] ;Was this the first one?
SKIPGE RET2,PPN ;Have we already seen two matches?
JRST L04 ; Yes, don't consider partial match on PPN
JUMPN RET2,[CALL FSREL,PPN ;If we've already seen one, flush both
SETOM PPN ;Mailbox not valid
JRST L04] ;Look for match on PPN
DPB RET,TEM ;Replace <tab> with <null>
CALL COPSTR,<[POINT 7,NAMBUF]> ;copy string into new free storage block
MOVEM RET,PPN ;remember match so far (FS block adr)
JRST L04
; ---
DONEOK: CALL FSREL,RET ;free up the "winning" string
FILEOK: CALL COPSTR,KEYSTR ;and return the original string
JRST DONE
;Check host name. We lie for now. Just take anything and let MAIL worry
;about it.
CHKHST: jrst fileok
; ---
L09: SKIPLE RET,PPN ;Skip if bad name
JRST DONEOK ; Good, return PPN for name
JUMPL RET,[MOVNI RET,RCILMB ;Mailbox not valid
MOVEI RET2,[ASCIZ/Name ambiguous: /]
JRST DONE ]
AOS NOTFST ;No longer scanning first file
MOVEI RET,4 ;Advance to next file
ADDB RET,FILES
SKIPE (RET) ;Last file to search?
JRST L00 ; No, try another.
MOVNI RET,RCILMB ;Mailbox not valid
MOVEI RET2,[ASCIZ/No such user: /]
; \ /
DONE: RELEAS INCHN,
POPP NP ;Restore ACs
POPP KP
POPP CNT
POPP TEM
RETURN
SUBREND FNDUSR
SUBR COPSTR,STRPTR ;Copy a string
COMMENT ⊗ ---------------------------------------------------------------------
Calling Sequence:
PUSH P,<string pointer>
PUSHJ P,COPSTR
Returns:
RET: pointer to new string
Description:
Copies string into new free storage block.
Algorithm:
Always use string pointer to search for first null.
If string is word aligned, BLT is used to copy. Otherwise, uses ILDB/IDPB.
We fixup the last word if byte pointer wasn't POINT 7,xxx or 0 in left half.
Calls:
FSGET
Side effects:
Gets free storage
Clobbers RET2
⊗;------------------------------------------------------------------------------
PUSHP TAC
SETZ TAC, ;Count character or words
MOVE RET2,STRPTR
TLNN RET2,-1 ;Is it a string pointer?
HRLI RET2,(<POINT 7,0>) ; Now it is.
SRCHLP: ILDB RET,RET2 ;Get a character from string
ADDI TAC,1 ;Count each character, including null.
JUMPN RET,SRCHLP ;More left to go
; \ /
SRCHDN: MOVEI RET,4(TAC) ;Round up for null
IDIVI RET,5
MOVEI TAC,-1(RET) ;Remember last word
CALL FSGET↑,RET ;Get a block of free storage
ADD TAC,RET ;Point to end of string
HLRZ RET2,STRPTR ;Get string pointer
JUMPE RET2,USEBLT ;If word aligned, use BLT
CAIN RET,(<POINT 7,0>) ;Another kind of byte pointer for words
JRST USEBLT ; OK
CAIN RET,(<POINT 7,0,34>) ;Yet another
JRST USEBL2 ; But this one is special
MOVE RET2,STRPTR ;Oh, well. We tried.
MOVE TAC,RET
HRLI TAC,(<POINT 7,0>)
PUSHP TAC2 ;We've gone this far without it.
BYTELP: ILDB TAC2,RET2 ;Mindlessly copy
IDPB TAC2,TAC
JUMPN TAC2,BYTELP ;Waiting for a null
POPP TAC2
JRST DONE
; ---
;We can BLT, but we had better check the last word for extra garbage
USEBL2: HRLZ RET2,STRPTR ;Yes, but watch out
SUBI RET2,1
HRR RET2,RET ;New block is destination
BLT RET2,(TAC) ;Copy!
HRLI TAC,<POINT 7,0> ;Now, make sure it is pure ASCIZ
USEBL3: ILDB RET2,TAC ;Look for the first null
JUMPN RET2,USEBL3 ;Jump if it isn't
USEBL4: TLNE RET2,760000 ;At end of word yet?
JRST DONE ; Yes, done
IDPB RET2,TAC ;Fill some nulls
JRST USEBL4 ;And try again
; ---
;Easy case. From the looks of the string pointer, we can assume it is a
;properly formed ASCIZ string (i.e. all padding is nulls in last word).
USEBLT: HRLZ RET2,STRPTR ;Use old string as source
HRR RET2,RET ;New block is destination
BLT RET2,(TAC) ;Copy!
DONE: POPP TAC
RETURN ;And we're done!
SUBREND COPSTR
SUBR UPSTR,STRPTR ;Convert string to upper case
COMMENT ⊗ ---------------------------------------------------------------------
Calling Sequence:
PUSH P,<string pointer>
PUSHJ P,UPSTR
Returns:
Undefined
Description:
Converts any lower case characters in a string into upper case.
Calls:
Nothing
Side effects:
Modifies string
Clobbers RET,RET2
⊗;------------------------------------------------------------------------------
MOVE RET,STRPTR ;Get string pointer
TLNN RET,-1 ;Is it a word pointer?
HRLI RET,(<POINT 7,0>) ; Yes, make it a byte pointer
LOOP: ILDB RET2,RET ;Get a character
CAIL RET2,"a" ;Is it lower case?
CAILE RET2,"z"
JUMPN RET2,LOOP ; No, look for another if not a null
JUMPE RET2,[RETURN] ;If it's a null, we're done
SUBI RET2,"a"-"A" ;Convert to upper cae
DPB RET2,RET
JRST LOOP ;And try next character
SUBREND UPSTR
SUBR HASHER,VALUE ;Hash a number into another number
COMMENT ⊗ ---------------------------------------------------------------------
Calling Sequence:
PUSH P,<36 bit integer>
PUSHJ P,HASHER
Returns:
RET: A different 36 bit integer.
Description:
Turns a input into reproducible gibberish.
Calls:
Nothing
Side effects:
Gets free storage
Clobbers RET,RET2
⊗;------------------------------------------------------------------------------
MOVE RET,VALUE
MUL RET,[=630630016] ;Extracted from SAIL's RAN$ function, which
ASHC RET,4 ; appears to be from the FORTRAN library
LSH RET,-4 ;It will do for now.
ADD RET,RET2
RETURN
SUBREND HASHER
SUBR SYBSRH,STRADR,TABADR ;Symbol lookup
COMMENT ⊗ ---------------------------------------------------------------------
Calling Sequence:
PUSH P,<address of string>
PUSH P,<address of table>
PUSHJ P,SYBSRH
Returns:
RET: value (or 0 if not found)
RET2: pointer to symbol table entry
Description:
Looks up string in symbol table.
CAUTION: It take word pointers, not byte pointers
Algorithm:
Assumes that symbol table is in alphabetical order and does a binary search.
Calls:
Nothing
Side effects:
Clobbers TAC
⊗;------------------------------------------------------------------------------
ACCUMULATORS{DEL,P1,P2}
PUSHP P1
PUSHP P2
MOVE RET2,TABADR ;Get address of table
HRRE DEL,-1(RET2) ;Get -length of table
MOVN DEL,DEL
addi del,1 ;*** Fudge
ASH DEL,-1 ;Split table in half
ADD RET2,DEL ;Advance to half way point
; \ /
LOOP: caie del,1 ;*** Kludge to make it work. Sigh...
addi del,1
ASH DEL,-1 ;Split table in half for next iteration
HRRZ P1,(RET2) ;Get string address from table
JUMPE P1,[CAME RET2,TABADR ;Check boundary, which edge
JRST TOOBIG
JRST TOOSML]
MOVE P2,STRADR ;Get search string for comparion
SUBI P1,(P2) ;Fix so we can index by P2
HRLI P1,P2 ;Setup for indirection (do it every time
;in case the SUBI carries into left half)
; \ /
LOOP2: MOVE RET,@P1 ;Get something from table
CAME RET,(P2) ;Match?
JRST[ CAMG RET,(P2) ;No, too small?
TOOSML: JRST[ ADD RET2,DEL ;Yes, try higher
JUMPN DEL,LOOP ;Assuming we can
JRST NOTFND ] ;We can't
TOOBIG: SUB RET2,DEL ;No, try lower
JUMPN DEL,LOOP ;Assuming we can
NOTFND: SETZ RET, ;None left, not found
JRST DONE ]
TRNE RET,177*2 ;End of string?
AOJA P2,LOOP2 ; No, try another word
HLRZ RET,(RET2) ;Get value
DONE: POPP P2
POPP P1
RETURN
SUBREND SYBSRH
SUBR SYBSRP,STRADR,TABADR ;Symbol lookup with partial match
COMMENT ⊗ ---------------------------------------------------------------------
Calling Sequence:
PUSH P,<address of string>
PUSH P,<address of table>
PUSHJ P,SYBSRP
Returns:
RET: value (or 0 if not found and -1 if ambiguous)
RET2: pointer to symbol table entry
Description:
Looks up string in symbol table, accepting abbreviation
CAUTION: It take word pointers, not byte pointers
Algorithm:
Calls SYBSRH and then fixes things up if it fails.
Calls:
SYBSRH
Side effects:
Clobbers TAC
⊗;------------------------------------------------------------------------------
ACCUMULATORS{TP,S1,S2,MATCH}
SKIPN RET,@STRADR ;Make sure there's something there!
JRST [RETURN] ; This shouldn't happen.
PUSHP S1 ;Save some ACs we'd like to use
PUSHP S2
PUSHP MATCH
MOVE TP,TABADR
HRL TP,-1(TP) ;Setup to check it and some neighbors
AOBJP TP,[PUSHJ P,DRYROT] ;Skip first, do bug trap
SETZ MATCH, ;No matches yet.
L1: HRRE S1,(TP) ;Get pointer to string, if any
JUMPLE S1,[PUSHJ P,DRYROT] ;If no string, have bug.
MOVE S2,STRADR ;Get address of string
HRLI S1,(<POINT 7,0>) ;Make into character pointers
HRLI S2,(<POINT 7,0>)
L2: ILDB RET,S1 ;Search each string
ILDB RET2,S2
CAMN RET,RET2
JUMPN RET,L2
JUMPE RET2,[ ;Jump if end of search string
JUMPE RET,[MOVEI RET2,(TP) ;Perfect match
JRST L4]
JUMPN MATCH,[SETO RET, ;If we're match already, ambiguous.
JRST DONE]
MOVEI MATCH,(TP) ;Remember we've seen one.
JRST L3 ] ;And go look for more
CAMG RET,RET2 ;Past end of possible matches?
L3: AOBJN TP,L1 ; No, more to try
SKIPN RET2,MATCH ;Get match, if any
TDZA RET,RET ; No match
L4: HLRE RET,(RET2) ;Get value part from table
DONE: POPP MATCH ;Restore ACs and we're done.
POPP S2
POPP S1
RETURN
SUBREND SYBSRP
SUBR PFCONS ;Make a LISP cell.
COMMENT ⊗ ---------------------------------------------------------------------
Calling Sequence:
MOVE RET,<CAR>
MOVE RET2,<CDR>
PUSHJ P,PFCONS
Returns:
RET: internal LISP type cell
CAUTION:
Arguments are not on the stack.
Description:
Does LISP style CONS operation
Algorithm:
Tries to get a cell from free list for CONS cells.
Failing that, it makes a new free list by getting a block of free storage.
Calls:
FSGET
Side effects:
Clobbers left half of RET2
Gets free storage if list space is exhausted.
⊗;------------------------------------------------------------------------------
PFLBSZ←←=510 ;Number of words to use to enlarge freelist
HRL RET2,RET ;Construct contents of cell in an AC
RETRY: SKIPN RET,PFLAVL ;Get first free element
JRST EMPTY ; No freelist
EXCH RET2,(RET) ;Put contents of cell into cell, get pointer to
;next element of free list
MOVEM RET2,PFLAVL ;New head of freelist
HRRZ RET2,(RET) ;Restore RET2, right half at least
RETURN
; ---
EMPTY: PUSHP RET2 ;Save contents of cell on stack.
CALL FSGET↑,<[PFLBSZ]> ;Get a convenient size of block for LISPish cells
MOVEM RET,PFLAVL ;Start setting up freelist
HRLI RET,1-PFLBSZ ;Number of cells to setup
SKIPA ;Don't do first store
LOOP: HRRZM RET,-1(RET) ;Point previous at current
AOBJN RET,LOOP ;Repeat for n-1 cells (but first store was skipped)
SETZM -1(RET) ;Last cell is end of list
POPP RET2
JRST RETRY ;Now, try again
SUBREND PFCONS
SUBR PFUNCS ;Release a LISP cell.
COMMENT ⊗ ---------------------------------------------------------------------
Calling Sequence:
MOVE RET,<cell>
PUSHJ P,PFUNCS
Returns:
Undefined
CAUTION:
Argument is not on the stack.
Description:
Immediately releases a LISPish cell. This is in leiu of a garbage
collector.
Algorithm:
Puts cell on free list.
Calls:
Nothing
Side effects:
Affects free list (PFLAVL)
Destroys only RET and the cell it contained.
⊗;------------------------------------------------------------------------------
HRRZ RET,RET ;Bulletproofing
EXCH RET,PFLAVL ;Make new cell head of free list
HRRZM RET,@PFLAVL ;Point new cell at existing list
RETURN ;Done!
SUBREND PFUNCS
SUBR CVPPN,STRING ;Convert from string to PPN
COMMENT ⊗ ---------------------------------------------------------------------
Calling Sequence:
PUSH P,[<address of string>]
PUSHJ P,CVPPN
Returns:
RET: SIXBIT form of PPN
Description:
Converts string to PPN
Calls:
CVSIX
Side effects:
Destroys only RET and RET2
⊗;------------------------------------------------------------------------------
CALL CVSIX,STRING ;Read project
JUMPE RET,[LDB RET,RET2 ;If empty, get terminator
CAIE RET,"[" ;Is ...] remaining?
JRST .+1 ; No, must be confused
CALL CVSIX,RET2 ;This time for sure!
JRST .+1]
TRZ RET,-1 ;Clobber right half
TLNN RET,77 ;Is it right justified in left half?
JUMPN RET,[
LSH RET,-6 ; No, move right and try again
JRST .-1 ]
PUSHP RET ;Save project for the moment
LDB RET,RET2 ;Get terminating character
JUMPE RET,[ ; None, invent a project
MOVSI RET,' 1'
EXCH RET,(P) ; Swap with programmer
JRST NOPRJ ]
CALL CVSIX,RET2 ;Read programmer
TRZ RET,-1 ;Zap right half
TLNN RET,77 ;Is it right justified in left half?
JUMPN RET,[
LSH RET,-6 ; No, move right and try again
JRST .-1 ]
NOPRJ: POPP RET2 ;Get back project
HLRZ RET,RET ;Put programmer in the proper half
ADD RET,RET2 ;Add in project
RETURN
SUBREND CVPPN
SUBR CVSIX,STRING ;Convert to SIXBIT
COMMENT ⊗ ---------------------------------------------------------------------
Calling Sequence:
PUSH P,[<address of string>]
PUSHJ P,CVSIX
Returns:
RET: SIXBIT form of string
RET2: Remainder of string
Description:
Converts string to SIXBIT. Stops on ':' or '-'
Calls:
Nothing
Side effects:
Destroys only RET and RET2
⊗;------------------------------------------------------------------------------
HLLZ RET,STRING ;Already a string pointer?
JUMPE RET,[MOVSI RET,(<POINT 7,0>)
HLLM RET,STRING ;Now it is
JRST .+1]
MOVEI RET,STRING ;Point to string pointer
HRLI RET,(<ILDB RET,>)
PUSHP 0
CALL RDSIX↑,RET,<[BRKTAB]>
POPP 0
MOVE RET2,STRING
RETURN ;Done!
BRKTAB: BYTE (32) -1 (1) 1,0,0,1 ;<SAIL chars> <space>!"#
BYTE (6) 0 (1) 1,0,1,1 (12) 0 (1) 1 (4) 0 (1) 1,0 (7) 0
;$%&'() *+,- ./0..9 : ;<=> ?@ ABCDEFG
BYTE (19) 0 (1) 1,0,1,1,1,1 (11) 0 ;H..Z [\]↑←` abcdefghijk
BYTE (15) 0 (5) -1 ;lmnopqrstuvwxyz {|<alt>}<DEL>
SUBREND CVSIX
SUBR GETMRK ;Read a mark
COMMENT ⊗ ---------------------------------------------------------------------
Calling Sequence:
PUSHJ P,GETMRK
Returns:
RET: Code for mark
Description:
Reads code from a MARK packet.
Calls:
System
Side effects:
Clears MRKFLG
Clobbers RET,RET2
⊗;------------------------------------------------------------------------------
pushj p,pupget ;Gets first mark. Sigh...
skipa
jrst[ pushj p,warnmsg
errarg txt,[asciz"Text w/o mark: "]
0
xct ermsop
call pipeit,puprop,ermsop
call wrascz↑,<[[asciz/
/]]>,ermsop↔ jrst .+1 ]
SKIPN MRKFLG ;This had better be set.
JRST[ STATO PUPCHN,IODEND ; Well, maybe they closed the connection
PUSHJ P,DRYROT ; No, lose big
JRST CLOSED ] ; Usual place to clean up
PUSHP RET+2 ;The MTAPE wants three locations, we don't want
;worry about the symbol for RET+2 or what it has.
MOVEI RET,PUPRMR ;MTAPE code for send mark
MTAPE PUPCHN,RET ;Read the mark
JRST[ PUSHJ P,PUPERR
ERRARG TXT,[ASCIZ/Couldn't read MARK/]
ERRARG CRLF,0
0
setz ret, ;Lose, lose
JRST DONE ] ;I don't think we return, but in case...
SETZM MRKFLG ;We got our mark
DONE: MOVE RET,RET+2 ;Get value to return
POPP RET+2 ;Restore borrowed AC
RETURN
SUBREND GETMRK
SUBR SNDMRK,MRKCOD ;Send a mark
COMMENT ⊗ ---------------------------------------------------------------------
Calling Sequence:
PUSH P,MRKCOD ;Code for mark PUP
PUSHJ P,SNDMRK
Returns:
Undefined
Description:
Sends a mark with specified code.
Calls:
System
Side effects:
Sends to EtherNet
Does not clobber any ACs
⊗;------------------------------------------------------------------------------
PUSHP RET ;The MTAPE wants three locations, we don't want
PUSHP RET+1 ;worry about the symbol for RET+2 or what it has.
PUSHP RET+2
repeat 0,<
PUSHJ P,SETPAD ;Set padding for output
>;repeat 0
printx Kludge to get around bug in PUPSER(?)
hrrz ret,pupohd
add ret,[point 8,1]
came ret,pupohd+1
OUT PUPCHN, ;*** Flush out buffer before sending MARK
JRST OUTOK
GETSTS PUPCHN,RET
printx Is this code still needed?
trnn ret,777760-iodmrk ;Was lossage due to mark being set?
jrst[ trzn ret,iodmrk
jrst .+1 ; Nope.
setom mrkflg ;Sigh... Let recieve side worry.
jrst outok ]
TRNE RET,IODEND ;Connection disappeared?
JRST CLOSED ; Yep.
PUSHJ P,PUPERR
ERRARG TXT,[ASCIZ/Output error, status = /]
ERRARG OCT,RET
ERRARG CRLF,0
0
OUTOK:
MOVEI RET,PUPSMR ;MTAPE code for send mark
MOVE RET+2,MRKCOD ;Get code for mark
MTAPE PUPCHN,RET ;Send a mark
JRST[ PUSHJ P,PUPERR
ERRARG TXT,[ASCIZ/Couldn't send MARK/]
ERRARG CRLF,0
0
JRST DONE ] ;I don't think we return, but just in case...
DONE: POPP RET+2 ;Restore borrowed AC
POPP RET+1
POPP RET
RETURN
SUBREND SNDMRK
SUBR SNDMK2,MRKCOD,SUBCOD,STRPTR ;Send a marked messages
COMMENT ⊗ ---------------------------------------------------------------------
Calling Sequence:
PUSH P,MRKCOD ;Code for mark PUP
PUSH P,SUBCOD ;First byte of next data packet
PUSH P,STRPTR ;Rest of next data packet
PUSHJ P,SNDMK2
Returns:
Undefined
Description:
Sends a message consisting of a mark code, another code, a string, and
an end of command mark. It is generally used for acknowledgements.
Algorithm:
Sends a mark with specified code.
Sends SUBCOD as first byte of string, the rest of the string being
pointed to by STRPTR. It is followed by an End-Of-Command mark.
Calls:
SNDMRK,PUPPUT
Side effects:
Sends to EtherNet
Clobbers RET,RET2
⊗;------------------------------------------------------------------------------
CALL SNDMRK,MRKCOD ;Send mark for command
MOVE RET,SUBCOD ;Send code for message
PUSHJ P,PUPPUT
CALL WRASCZ↑,STRPTR,<[PUSHJ P,PUPPUT]>
;Send string
CALL SNDMRK,<[MKEOC]> ;Send End-of-Command.
RETURN
SUBREND SNDMK2
SUBR PIPEIT,READOP,WRITEOP ;Copy from input stream to output stream
COMMENT ⊗ ---------------------------------------------------------------------
Calling Sequence:
PUSH P,[<instruction to read a character>]
PUSH P,[<instruction to write a character>]
PUSHJ P,PIPEIT
Returns:
Undefined
Description:
Sends a message consisting of a mark code, another code, a string, and
an end of command mark. It is generally used for acknowledgements.
Calls:
Nothing sides what READOP and WRITEOP may call.
Side effects:
Clobbers RET (and nothing else unless the stream ops are buggy)
⊗;------------------------------------------------------------------------------
PIPELP: XCT READOP ;Get a character from PUP
JUMPE RET,[RETURN] ;Zero means EOF or Mark seen.
XCT WRITEOP ;Stuff character in output buffer
JRST PIPELP ;Repeat until EOF is seen.
SUBREND PIPEIT
;⊗ GETCHR GETCH1 GETCH2 GETCH3 GETCH4 GTEDIR GTEDIL GETBYT GETCH6 PUTBYT PUTCH2
;------------------------------------------------------------------------------
;
; Default (disk) I/O routines
;
; CAUTION: GETBYT skips on success.
;
;------------------------------------------------------------------------------
;Get a character from input file, return zero on EOF. Obviously, any nulls
;are flushed, along with SOS line numbers. No attempt is made to skip E
;directories.
GETCHR: PUSHJ P,GETBYT ;Advance buffer pointer
POPJ P, ; EOF
MOVE RET,@INHDR+1 ;Pick up word to examine for SOSness
TRNE RET,1 ;Low order bit on?
JRST GETCH2
GETCH1: LDB RET,INHDR+1 ;Get character again
JUMPE RET,GETCHR ;Flush nulls immediately
;;; AOS (P) ;Got something useful
;;; CAIN RET,14 ;Form feed?
;;; JRST [AOS PAGCNT ;Yes, fix up count
;;; SETZM LINCNT
;;; AOS LINCNT
;;; POPJ P,]
;;; CAIN RET,12 ;Line feed?
;;; AOS LINCNT
POPJ P, ; No, return then
GETCH2: AND RET,[BYTE (7) 160,160,160,160,160]
CAMN RET,[ASCII/00000/] ;SOS Line number?
JRST GETCH3
CAMN RET,[ASCII/ /] ;SOS Page mark?
JRST GETCH4
JRST GETCH1 ;None, treat as ordinary characters
;SOS Line number
GETCH3: PUSHJ P,GETBYT ;Skip past expected TAB
POPJ P, ; Unexpected EOF, ignore...
CAIE RET,11 ;Tab?
JRST GETCH3 ; No, loop
JRST GETCHR ;Yes, get real character
;SOS Page mark
GETCH4: PUSHJ P,GETBYT ;Skip upto expected FF
POPJ P, ; Unexpected EOF, ignore...
CAIE RET,14 ;Formfeed?
JRST GETCH3 ; No, loop
JRST GETCH1 ;Yes, return it
;Check for E directory and skip over it, if found.
GTEDIR: SKIPLE INHDR+2 ;make sure we're reading at beginning of record
POPJ P, ;not beginning of record (so not beg of file)
IN INCHN, ;get first record of file
AOSA INHDR+2 ;fix byte count in case no E directory
POPJ P, ;not E directory if EOF already
MOVE RET,INHDR+1 ;get byte ptr (before first ILDB) to first rec
IBP RET ;make sure it points to first word of buffer
MOVE RET2,(RET) ;get first word of buffer
CAME RET2,[ASCII/COMME/]
POPJ P, ;not E directory
MOVE RET2,1(RET) ;get 2nd word of buffer
CAME RET2,[ASCII/NT ⊗ /]
POPJ P, ;not E directory
MOVE RET2,2(RET) ;3rd word of buffer
CAME RET2,[ASCII/INVAL/] ;skip over either INVALID or VALID E directory
CAMN RET2,[ASCII/ VAL/]
SKIPA RET2,3(RET) ;4th word of buffer
POPJ P, ;not E directory
TRZ RET2,177⊗8+177⊗1 ;clear rightmost 2 chars of 4th word
CAME RET2,[ASCII/ID /]
POPJ P, ;not E directory
GTEDIL: PUSHJ P,GETBYT ;E directory seen, skip to formfeed ending it
JRST [ USETI INCHN,1 ;EOF without FF, bad E directory
POPJ P,] ;make beginning of file get re-read
CAIE RET,14 ;skip if formfeed
JRST GTEDIL ;keep looking for formfeed
POPJ P, ;OK, all done, next char is after formfeed
;Get character from system buffer, skip unless EOF.
GETBYT: SOSG INHDR+2 ;Any characters left in buffer?
IN INCHN, ; No, ask system for more
JRST [
GETCH6: ILDB RET,INHDR+1 ;Get character and
AOS (P) ;Skip return means success
POPJ P, ] ;Return
STATO INCHN,IODEND ;Error from IN, is it EOF?
JRST [ GETSTS INCHN,RET
PUSHJ P,WARNMSG
ERRARG TXT,[ASCIZ/Read error from device /] ;No, an error!
ERRARG SIX,INBLK+1
ERRARG TXT,[ASCIZ/, status = /]
ERRARG OCT,RET
ERRARG CRLF,0
AOS INERRS
JRST GETCH6 ]
SETZ RET, ;Return zero at EOF for GETCHR
POPJ P, ;Non-zkip return means failure
;Put character onto output file
PUTBYT: SOSG OUTHDR+2 ;Space left in buffer
OUT OUTCHN, ; No, output it to get some more
PUTCH2: JRST [ IDPB RET,OUTHDR+1 ;Stuff character in output buffer
POPJ P,] ;And return
GETSTS INCHN,RET
PUSHJ P,WARNMSG
ERRARG TXT,[ASCIZ/Write error from device /] ;No, an error!
ERRARG SIX,INBLK+1
ERRARG TXT,[ASCIZ/, status = /]
ERRARG OCT,RET
ERRARG CRLF,0
AOS OUTERRS
JRST PUTCH2
;⊗ CMDGET CMDCHR CMDEOF CMDCH1 CMDCH2 CMDCH3 CMDCH4 CMDBYT CMDCH6
;Get character from command string. This could also be made to read
;from a command file
CMDGET: INCHWL 1 ;Get a character, activate on end of line
SOS RESCNT ;For initialization
POPJ P,
;Get a character from input file, return zero on EOF. Obviously, any nulls
;are flushed, along with SOS line numbers. No attempt is made to skip E
;directories.
CMDCHR: PUSHJ P,CMDBYT ;Advance buffer pointer
;;; POPJ P, ; EOF
CMDEOF: jrst[ call wrascz↑,<[[asciz/*** End of command file ***/]]>,ermsop
push p,[pushj p,cmdget]
pop p,cmdop
setzm xindsw ;No longer continuable
jrst cmdget ]
MOVE RET,@CMDHDR+1 ;Pick up word to examine for SOSness
TRNE RET,1 ;Low order bit on?
JRST CMDCH2
CMDCH1: LDB RET,CMDHDR+1 ;Get character again
JUMPE RET,CMDCHR ;Flush nulls immediately
;;; AOS (P) ;Got something useful
;;; CAIN RET,14 ;Form feed?
;;; JRST [AOS PAGCNT ;Yes, fix up count
;;; SETZM LINCNT
;;; AOS LINCNT
;;; POPJ P,]
;;; CAIN RET,12 ;Line feed?
;;; AOS LINCNT
xct ermsop ;Echo character read
POPJ P, ; No, return then
; ---
CMDCH2: AND RET,[BYTE (7) 160,160,160,160,160]
CAMN RET,[ASCII/00000/] ;SOS Line number?
JRST CMDCH3
CAMN RET,[ASCII/ /] ;SOS Page mark?
JRST CMDCH4
JRST CMDCH1 ;None, treat as ordinary characters
;SOS Line number
CMDCH3: PUSHJ P,CMDBYT ;Skip past expected TAB
jrst cmdeof ; Unexpected EOF, ignore...
CAIE RET,11 ;Tab?
JRST CMDCH3 ; No, loop
JRST CMDCHR ;Yes, get real character
;SOS Page mark
CMDCH4: PUSHJ P,CMDBYT ;Skip upto expected FF
jrst cmdeof ; Unexpected EOF, ignore...
CAIE RET,14 ;Formfeed?
JRST CMDCH3 ; No, loop
JRST CMDCH1 ;Yes, return it
;Get character from system buffer, skip unless EOF.
CMDBYT: SOSG CMDHDR+2 ;Any characters left in buffer?
IN CMDCHN, ; No, ask system for more
JRST [
CMDCH6: ILDB RET,CMDHDR+1 ;Get character and
AOS (P) ;Skip return means success
POPJ P, ] ;Return
STATO CMDCHN,IODEND ;Error from IN, is it EOF?
JRST [ GETSTS CMDCHN,RET
PUSHJ P,WARNMSG
ERRARG TXT,[ASCIZ/Read error from device /] ;No, an error!
ERRARG SIX,CMDBLK+1
ERRARG TXT,[ASCIZ/, status = /]
ERRARG OCT,RET
ERRARG CRLF,0
JRST CMDCH6 ]
SETZ RET, ;Return zero at EOF for CMDBYT
POPJ P, ;Non-zkip return means failure
;UFDWRD UFDWR6 MFDWRD MFDWR6
;Get word from UFD buffer
UFDWRD: SOSG UFDHDR+2 ;Any characters left UFD buffer?
IN UFDCHN, ; No, ask system for more
JRST [
UFDWR6: ILDB RET,UFDHDR+1 ;Get character and
AOS (P) ;Skip return means success
POPJ P, ] ;Return
STATO UFDCHN,IODEND ;Error from IN, is it EOF?
JRST [ GETSTS UFDCHN,RET
PUSHJ P,WARNMSG ;No, an error!
ERRARG TXT,[ASCIZ/UFD read error from device /]
ERRARG SIX,UFDBLK+1
ERRARG TXT,[ASCIZ/, status = /]
ERRARG OCT,RET
ERRARG CRLF,0
AOS UFDERRS
JRST UFDWR6 ]
POPJ P, ;Non-zkip return means failure
;Get word from MFD buffer
MFDWRD: SOSG MFDHDR+2 ;Any characters left MFD buffer?
IN MFDCHN, ; No, ask system for more
JRST [
MFDWR6: ILDB RET,MFDHDR+1 ;Get character and
AOS (P) ;Skip return means success
POPJ P, ] ;Return
STATO MFDCHN,IODEND ;Error from IN, is it EOF?
JRST [ GETSTS MFDCHN,RET
PUSHJ P,WARNMSG ;No, an error!
ERRARG TXT,[ASCIZ/MFD read error from device /]
ERRARG SIX,MFDBLK+1
ERRARG TXT,[ASCIZ/, status = /]
ERRARG OCT,RET
ERRARG CRLF,0
AOS MFDERRS
JRST MFDWR6 ]
POPJ P, ;Non-zkip return means failure
;Must preserve buffer rings during OPEN
INOPEN: PUSH P,INHDR
OPEN INCHN,INBLK
CAIA
AOS -1(P)
POP P,INHDR
SKIPE INHDR ;Have we allocated for this one yet?
POPJ P,
PUSH P,RET ;No, let's pick something claimed to be optimal
MOVEI RET,INCHN
BLKLEN RET,
HLRZ RET,RET
INBUF INCHN,(RET)
POP P,RET
POPJ P,
OUTOPN: PUSH P,OUTHDR
OPEN OUTCHN,OUTBLK
CAIA
AOS -1(P)
POP P,OUTHDR
SKIPE OUTHDR
POPJ P,
PUSH P,RET ;No, let's pick something claimed to be optimal
MOVEI RET,OUTCHN
BLKLEN RET,
HLRZ RET,RET
OUTBUF OUTCHN,(RET)
POP P,RET
POPJ P,
UFDOPN: PUSH P,UFDHDR
OPEN UFDCHN,UFDBLK
CAIA
AOS -1(P)
POP P,UFDHDR
POPJ P,
MFDOPN: PUSH P,MFDHDR
OPEN MFDCHN,MFDBLK
CAIA
AOS -1(P)
POP P,MFDHDR
SKIPE MFDHDR ;MFD is huge, try to search it a little faster.
POPJ P,
INBUF MFDCHN,=9
POPJ P,
;PUPGET PUPGE6 PUPGE5 pupgem PUPROP pupro2 PUPPUT PUPPU2 PUPPU4 PUPPU5 PUPWOP SETPAD
;------------------------------------------------------------------------------
;
; Ethernet byte I/O routines
;
; MORE KLUDGES THAN NOT!
;
;------------------------------------------------------------------------------
;
;Get character from system buffer
;
PUPGET: SOSLE PUPIHD+2 ;Any characters left in buffer?
JRST [ ; Yes, take them first
PUPGE6: ILDB RET,PUPIHD+1 ;Get character and
AOS (P) ;Skip return means success
POPJ P, ] ;Return
IN PUPCHN, ; No, ask system for more
JRST[
MOVE RET,PUPIHD+2 ;Get byte count
ADDM RET,EIBYTS ;Update transfer rate info
JRST PUPGE6 ]
GETSTS PUPCHN,RET ;Get status of PUP
TRZE RET,IODMRK ;Is it a mark?
JRST[ SETOM MRKFLG ; Yes, remember we saw one. (Cleared by GETMRK)
;;;IODMRK being an error bit, we must do this for output to win. Sigh...
;;;IFE PUP82,<
setsts pupchn,(ret) ;*** System doesn't turn this off, so
;*** we have to. Sigh...
skiple pupihd+2 ;*** We have seen data and a mark at once!
pushj p,dryrot ;*** Ooops, it bites again.
;;;>;IFE PUP82
pupgem: SETZ RET,
POPJ P,]
TRNN RET,IODEND ;Error from IN, is it EOF?
JRST [ GETSTS PUPCHN,RET
PUSHJ P,PUPERR
ERRARG TXT,[ASCIZ/Input error, status = /]
ERRARG OCT,RET
ERRARG CRLF,0
0
HALT PUPGE6 ]
SETZ RET, ;Return zero
POPJ P, ;Non-zkip return means failure
;Instruction to execute to get an ASCII character from PUP input.
;Returns zero if EOF or MARK.
PUPROP: PUSHJ P,.+1 ;Routine to execute to get a character
; \ / !!!
pupro2: PUSHJ P,PUPGET ;Get a character
TDZA RET,RET ;If EOF or mark, return zero
jumpe ret,[ ;Flush nulls
aos nnulls ;Count nulls
jrst pupro2 ]
POPJ P, ;Got a character.
;
;Put character onto output file
;
PUPPUT: SOSLE PUPOHD+2 ;Space left in buffer
JRST PUPPU5 ; Yes, use it
PUSHP RET ;Save character to be output
SKIPN RET,PUPOHD ;Has buffer ring been set up?
JRST PUPPU2 ; No need to count its bytes
LDB RET,[POINT 17,(RET),17] ;Get actual word count of buffer
SUBI RET,1 ;Subtract overhead
ASH RET,2 ;Convert from words to bytes
SUB RET,PUPOHD+2 ;Subtract number of bytes left
ADDM RET,EOBYTS ;Update byte count
repeat 0,<
PUSHJ P,SETPAD ;Set padding for PUP output
>;repeat 0
PUPPU2: OUT PUPCHN, ; No, output it to get some more
JRST PUPPU4
GETSTS PUPCHN,RET
trnn ret,777760-iodmrk ;Was lossage due to mark being set?
jrst[ trzn ret,iodmrk
pushj p,dryrot ; Nope.
setom mrkflg ;Sigh... Let recieve side worry.
jrst puppu4 ]
TRNE RET,IODEND ;Connection vanished?
JRST CLOSED ; Yeah, sigh...
PUSHJ P,PUPERR
ERRARG TXT,[ASCIZ/Output error, status = /]
ERRARG OCT,RET
ERRARG CRLF,0
0
; jrst puppu4 ;Ha, ha, ha...
; \ /?
PUPPU4: POPP RET ;Restore borrowed register
PUPPU5: IDPB RET,PUPOHD+1 ;Stuff character in output buffer
POPJ P, ;And return
;Opcode to output a character
PUPWOP: PUSHJ P,PUPPUT
repeat 0,< ;R.I.P.
;Set padding for output
;*** This can go away now...
SETPAD: LDB RET,[POINT 2,PUPOHD+1,2] ;Calculate padding from byte pointer
MOVE RET,[0↔1↔3↔7](RET)
SKIPE PUPOHD ;Make sure there is a buffer to stuff into
DPB RET,[POINT 4,@PUPOHD+1,35] ;Set padding bits
POPJ P,
>;repeat 0
;PNAMTB TNAMTB NTYPNM ELNMTB ELCR ELCRLF ELTRNS NELNMS
;-------------------------------------------------------------------------------
;
; Table of known property names
;
; Macro PNAMES is courtesy of Xerox PARC and is a list of macro calls to
; X of the form <internal mnemonic>,<property name>,<size for TENEX>
;
; We generate a table of with entries of the form:
; <property id>,,<pointer to text for property name>
;
;-------------------------------------------------------------------------------
DEFINE X '(SYM,NAME,SIZE) <
ST'SYM:P.'SYM,,[TX'SYM: ASCIZ/NAME/]
>
-NPNAMS ;Length of symbol table in the beginning
PNAMTB: 0 ;Nothing for zeroth element.
XLIST ;Save paper. You really don't want to see all
PNAMES
LIST
;------------------------------------------------------------------------------
;
; Type names
;
; (Format is same as PNAMTB)
;
;------------------------------------------------------------------------------
DEFINE X '(LETTER,NAME) <
TYPE.'LETTER,,[TXTYP'LETTER: ASCIZ/NAME/]
>
-NTYPNM ;Length of symbol table in the beginning
TNAMTB: 0 ;Nothing for zeroth element.
XLIST ;Save paper. You really don't want to see all
TNAMES
LIST
NTYPNM←←.-TNAMTB
;------------------------------------------------------------------------------
;
; EOL Conventions
;
; (Format is same as PNAMTB)
;
;------------------------------------------------------------------------------
-NELNMS
ELNMTB:
PHASE 0
0 ;Bad type
ELCR:: ELCR,,[ASCIZ/CR/]
ELCR,,[ASCIZ/CR-ONLY/]
ELCRLF::ELCRLF,,[ASCIZ/CRLF/]
ELCR,,[ASCIZ/CRONLY/]
ELTRNS::ELTRNS,,[ASCIZ/TRANSPARENT/]
DEPHASE
NELNMS←←.-ELNMTB
0 ;Keep SYBSRH from losing???
;UCMTAB NUCMDS
;------------------------------------------------------------------------------
;
; User commands table
;
;------------------------------------------------------------------------------
;CAUTION: If these are not in alphabetical order, you will lose in strange ways.
DEFINE UCMDS <
X ACCT,ACCOUNT
XX ACCT,ACCT
X ALIA,ALIAS
; X APPE,APPEND ;I don't think the protocol supports this?
XX TEXT,ASCII
XX QUIT,BYE
X BYTE,BYTE
XX ALIA,CWD
X DELE,DELETE
XX QUIT,DISCONNECT
XX EOLC,EOL-CONVENTION
X EOLC,EOLC
XX QUIT,EXIT
XX RETR,GET
X HELP,HELP
X LIST,LIST
XX USER,LOGIN
; X LPPN,LPPN ;I hope we don't have to support this!
; X MAIL,MAIL ;Someday, maybe
XX MLFL,MLFL
X NLST,NLST
; X PICK,PICKUP ;ARPA only
X QUIT,QUIT
X RETR,RETRIEVE
; X RNFR,RNFR ;Crufty ARPA form
; X RNTO,RNTO ;Crufty ARPA form
; X RPPN,RPPN ;I hope we don't have to support this!
XX LIST,STAT
X STOR,STORE
XX TNX,TENEX
X TEXT,TEXT
X TYPE,TYPE
X USER,USER
XX ALIA,XCWD
X XIND,XIND
>;DEFINE UCMDS
DEFINE X '(SYM,NAME,SIZE) <
US'SYM,,[ASCIZ/NAME/]
PRINTS/ SYM/ ;Say something for the folks back home
IFE I&7,<PRINTS/
/> ;Break it into several lines
↔ I←←I+1 ;Advance command counter
>
DEFINE XX '(SYM,NAME)
< -US'SYM-1,,[ASCIZ/NAME/]
;;;↔ I←←I+1 ;Advance command counter
>;DEFINE XX
↔ I←←1 ;Start with code of 1.
PRINTS/ Commands: /] ;Print what we defined.
-NUCMDS
UCMTAB: 0 ;Not possible (?)
XLIST
UCMDS
LIST
NUCMDS←←.-UCMTAB
0
0 ;Extra 0 for benefit of partial commands
PRINTS/
/ ;No more properties to print.
;Break tables
; HT LF CR ∞ ∂ ⊂⊃∩∪∀∃⊗↔ _ → ~ ≠ ≤ ≥ ≡ ∨ SP ! " #
FILBRK: BYTE (8) 0 (1) 0,1,1,0,0,1,0,0 (8) 0 (1) 0,1,0,0,0,0,0,0 (1) 1,0,0,0
; $%&()*+,-./0..7 8 9 : ; < = > ? @A..G
BYTE (4) 0 (8) 0,0 (1) 0,0,0,0,0,1,0,0 (8) 0
; H..W XYZ[\]↑ ← ` a..g hijk
BYTE (16) 0 (7) 0 (1) 1,0 (7) 0 (4) 0
; lmno p..w x y z { | ALT } BS
BYTE (4) 0 (8) 0 (1) 0,0,0,0,0,1,0,0
; HT LF CR ∞ ∂ ⊂⊃∩∪∀∃⊗↔ _ → ~ ≠ ≤ ≥ ≡ ∨ SP ! " #
LINBRK: BYTE (8) 0 (1) 0,1,1,0,0,1,0,0 (8) 0 (1) 0,0,0,0,0,0,0,0 (1) 0,0,0,0
; $%&()*+,-./0..7 8 9 : ; < = > ? @A..G
BYTE (4) 0 (8) 0,0 (1) 0,0,0,0,0,0,0,0 (8) 0
; H..W XYZ[\]↑ ← ` a..g hijk
BYTE (16) 0 (7) 0 (1) 0,0 (7) 0 (4) 0
; lmno p..w x y z { | ALT } BS
BYTE (4) 0 (8) 0 (1) 0,0,0,0,0,1,0,1
;Same as LINBRK except it also stops on ";"
; HT LF CR ∞ ∂ ⊂⊃∩∪∀∃⊗↔ _ → ~ ≠ ≤ ≥ ≡ ∨ SP ! " #
LINBR2: BYTE (8) 0 (1) 0,1,1,0,0,1,0,0 (8) 0 (1) 0,0,0,0,0,0,0,0 (1) 0,0,0,0
; $%&()*+,-./0..7 8 9 : ; < = > ? @A..G
BYTE (4) 0 (8) 0,0 (1) 0,0,0,1,0,0,0,0 (8) 0
; H..W XYZ[\]↑ ← ` a..g hijk
BYTE (16) 0 (7) 0 (1) 0,0 (7) 0 (4) 0
; lmno p..w x y z { | ALT } BS
BYTE (4) 0 (8) 0 (1) 0,0,0,0,0,1,0,1
;BEGZER PFLAVL RESCNT NNULLS MRKFLG BAUDRT NAMBUF NAMLEN HNAME HNAMSZ WAITSH SNBUF OLDPSW U.UNAM U.UPSW U.UACT U.DIRE U.TYPE U.EOLC U.BYTE PKTBUF PKTWSZ PKTBSZ ENDZER SRVRSW NOPRMT CMDOP SYSCMD INBLK INFILE INHDR INERRS OUTBLK OUTFIL OUTHDR OUTERRS PUPBLK PUPFIL PUPIHD PUPOHD EIBYTS EOBYTS MFDBLK MFDFIL UFDBLK UFDFIL MFDHDR UFDHDR MFDERRS UFDERRS FAKDEV UFDBUF PROBLK PROFIL HLPNAM CONBLK CONSTS CONLSK CONFSK CONHST LSNBLK LSNSTS LSNLSK LSNFSK LSNHST MSCBLK MSCSTS ERMSOP TYOPOS SDEBUG UDEBUG PKTLEN PKTTYP PKTBFD PKTLEN PKTTYP PKTBFD OLDACT NEWACT FAKEPL PDL PDLIOW
;------------------------------------------------------------------------------
;
; Variables initialized to zero
;
;------------------------------------------------------------------------------
BEGZER:: ;First location zeroed.
PFLAVL: BLOCK 1 ;Free list for LISPish cells
RESCNT: BLOCK 1 ;RESCAN count
NNULLS: BLOCK 1 ;Number of unexpected nulls received
MRKFLG: BLOCK 1 ;A mark has been seen on PUP input
BAUDRT: BLOCK 1 ;Baud rate of last transfer
NAMBUF: BLOCK =132/5 ;Allow extremely long names
NAMLEN←←5*(.-NAMBUF)-1 ;Length in character, plus a null.
HNAME: BLOCK 10 ;Moderately long host names
HNAMSZ←←.-HNAME
WAITSH: BLOCK 2 ;Name of this host
SNBUF: BLOCK SNSIZE ;Scratch block for making search nodes
OLDPSW: BLOCK 1 ;Last valid password for user name.
XINDSW: BLOCK 1 ;Non-zero when reading from file.
;Following are used by User FTP to keep track of user defaults.
U.UNAM: BLOCK 1 ;Pointer to user name
U.UPSW: BLOCK 1 ;Pointer to user password
U.UACT: BLOCK 1 ;Pointer to user account
U.DIRE: BLOCK 1 ;Pointer to directory (alias)
U.TYPE: BLOCK 1 ;Pointer to type code
U.EOLC: BLOCK 1 ;Pointer to End-of-Line convention
U.BYTE: BLOCK 1 ;Byte size (integer)
PKTBUF: BLOCK =140 ;Maximum packet size. Used to talk to Misc. Services.
PKTWSZ←←.-PKTBUF ;Size in words
PKTBSZ←←4*(.-PKTBUF) ;Size in 8 bit bytes.
ENDZER←←.-1 ;Last location zeroed
;The following are setup specially during startup.
SRVRSW: BLOCK 1 ;We are an FTP server if non-zero
NOPRMT: BLOCK 1 ;Non-zero to suppress prompt (once) for host name
CMDOP: PUSHJ P,CMDGET
;------------------------------------------------------------------------------
;
; Variables which are preloaded
;
;------------------------------------------------------------------------------
;Invocation from system
SYSCMD: ASCIZ/TEST/ ;Change to FTP when ARPA FTP knows about us.
;Input specification block for RDFILN, OPEN and LOOKUP
INBLK: 1 ;Device mode
SIXBIT/DSK/ ;Device name
XWD 0,INHDR ;Pointers to buffer headers
INFILE: BLOCK 1 ;SIXBIT/Filename/
BLOCK 1 ;SIXBIT/Extension/ (Other info. returned in right half)
BLOCK 1 ;(Date and protection returned here)
BLOCK 1 ;XWD 'Proj','Prog' (XWD proj,prog for DEC systems)
;Negative swapped length returned here by LOOKUP
BLOCK 1 ;Extra word to save PPN
BLOCK 1 ;Another extra word in case of long form LOOKUP
;Input buffer header for OPEN, IN
INHDR: BLOCK 3
INERRS: BLOCK 1 ;Number of input errors seen
;Output specification block for RDFILN, OPEN and ENTER
OUTBLK: 1
SIXBIT/DSK/ XWD OUTHDR,0
XWD OUTHDR,0
OUTFIL: BLOCK 4
BLOCK 1 ;Extra word to save PPN
BLOCK 1 ;Another extra word in case of long form LOOKUP
;Output buffer header for OPEN, OUT
OUTHDR: BLOCK 3
OUTERRS:BLOCK 1 ;Number of output errors seen
;Specification block for RDFILN, OPEN and ENTER
PUPBLK: 0 ;Buffered mode, use BSP
SIXBIT/PUP/
XWD PUPOHD,PUPIHD
PUPFIL: BLOCK 4
;Buffer headers for OPEN, IN, OUT
PUPIHD: BLOCK 3
PUPOHD: BLOCK 3
;Number of bytes transferred for each PUP channel
EIBYTS: BLOCK 1
EOBYTS: BLOCK 1
;Specification block for reading directories
MFDBLK: 10 ;Buffered mode, 36 bit bytes
SIXBIT/DSK/
XWD 0,MFDHDR
MFDFIL: SIXBIT / 1 1/
SIXBIT /UFD/
0
SIXBIT / 1 1/
BLOCK 1
UFDBLK: 10 ;Buffered mode, 36 bit bytes
SIXBIT/DSK/
XWD 0,UFDHDR
UFDFIL: SIXBIT /PRJPRG/
SIXBIT /UFD/
0
SIXBIT / 1 1/
BLOCK 1
;Buffer headers for OPEN, IN
MFDHDR: BLOCK 3
UFDHDR: BLOCK 3
;Number of MFD/UFD read errors
MFDERRS:BLOCK 1
UFDERRS:BLOCK 1
;Fake I/O spec. constructed from directory
FAKDEV: 0 ;No device name
0
UFDBUF: BLOCK 20 ;A little extra space
;Specification block for checking protection
PROBLK: 10 ;Buffered mode, 36 bit bytes
SIXBIT/DSK/
0 ;No data references
PROFIL: SIXBIT / 1 1/
SIXBIT /UFD/
0
SIXBIT / 1 1/
BLOCK 1
BLOCK 1
;Command file specification block for RDFILN, OPEN and LOOKUP
CMDBLK: 1 ;Device mode
SIXBIT/DSK/ ;Device name
XWD 0,CMDHDR ;Pointers to buffer headers
CMDFIL: BLOCK 1 ;SIXBIT/Filename/
BLOCK 1 ;SIXBIT/Extension/ (Other info. returned in right half)
BLOCK 1 ;(Date and protection returned here)
BLOCK 1 ;XWD 'Proj','Prog' (XWD proj,prog for DEC systems)
;Negative swapped length returned here by LOOKUP
;Input buffer header for OPEN, IN
CMDHDR: BLOCK 3
;Impure stuff from ACCCHK.FAI
ACCIMP ;Macro contains parts that are impure.
;Block for help file
HLPNAM: SIXBIT/DSK/
0
SIXBIT/PUPFTP/
SIXBIT/PUB/
0
SIXBIT/ SNET/
;
;Connection blocks
;
;User mode
CONBLK: PUPCON ;Opcode = CONNECT
CONSTS: 0 ;Status
CONLSK: FTPSKT ;Local socket
-1 ;Wait for connection
8 ;Bytesize (checked, but not used by PUP)
CONFSK: -1 ;Foreign socket (wild)
CONHST: 0 ;Host number
;Server mode
LSNBLK: PUPLSN ;Opcode = LISTEN
LSNSTS: 0 ;Status
LSNLSK: FTPSKT ;Local socket (GENSYM)
-1 ;Wait for connection
8 ;Bytesize (checked, but not used by PUP)
LSNFSK: -1 ;Foreign socket (wild)
LSNHST: 0 ;Host number
;For name request
MSCBLK: PUPLSN ;Opcode = LISTEN (we will broadcast)
MSCSTS: 0 ;Status
-1 ;Local socket (GENSYM)
0 ;Wait for connection
8 ;Bytesize (checked, but not used by PUP)
MSCSKT ;Foreign socket
-1 ;Host number
;Execute this to output one character of a error message
ERMSOP: OUTCHR RET
TYOPOS: 0 ;Used in LIST command to effect tabbing
;Debugging mode if non-zero. Prints human-readable part of commands
SDEBUG: 1 ;Server: Initially on.
UDEBUG: 1 ;User: Initially on.
;Pointers into PKTBUF
PKTLEN: POINT 16,PKTBUF,15 ;PUP length (in bytes)
PKTTYP: POINT 8,PKTBUF,31 ;PUP Type
PKTDHN: POINT 16,PKTBUF+2,15 ;Destination network/host
PKTBFD←←PKTBUF+5 ;Location of data within PUP
;Activation tables, used to turn off/on activation on BS at beginning of line
OLDACT: BLOCK 4
NEWACT: BLOCK 4
;Fake property list to make search list out of NAMBUF
FAKEPL: XWD .+1,0
XWD P.SFIL,NAMBUF
;Patch areas are good for you
PATCH↑: BLOCK 40
PDL: BLOCK 200 ;General purpose stack
PDLIOW: IOWD .-PDL,PDL ;Initial stack pointer which also by its being
;placed at the end of the stack, points to its
;beginning for backtracing.
END START